Line data Source code
1 : !------------------------------------------------------------------------------
2 : ! Harmonized Emissions Component (HEMCO) !
3 : !------------------------------------------------------------------------------
4 : !BOP
5 : !
6 : ! !MODULE: hco_calc_mod.F90
7 : !
8 : ! !DESCRIPTION: Module HCO\_Calc\_Mod contains routines to calculate
9 : ! HEMCO core emissions based on the content of the HEMCO EmisList
10 : ! object. All emissions are in [kg/m2/s].
11 : !\\
12 : !\\
13 : ! Emissions for the current datetime are calculated by multiplying base
14 : ! emissions fields with the associated scale factors. Different
15 : ! inventories are merged/overlayed based upon the category and hierarchy
16 : ! attributes assigned to the individual base fields. Within the same
17 : ! category, fields of higher hierarchy overwrite lower-hierarchy fields.
18 : ! Emissions of different categories are always added.
19 : !\\
20 : !\\
21 : ! The assembled emission array is written into the corresponding emission
22 : ! rates array of the HEMCO state object: HcoState%Spc(HcoID)%Emis, where
23 : ! HcoID denotes the corresponding species ID. Emis covers dimension lon,
24 : ! lat, lev on the HEMCO grid, i.e. unlike the emission arrays in EmisList
25 : ! that only cover the levels defined in the source files, Emis extends
26 : ! over all vertical model levels.
27 : !\\
28 : !\\
29 : ! Negative emissions are not supported and are ignored. Surface
30 : ! deposition velocities are stored in HcoState%Spc(HcoID)%Depv and can
31 : ! be added therein.
32 : !\\
33 : !\\
34 : ! In addition to emissions and surface deposition rates, HEMCO also
35 : ! supports concentrations (kg/m3). Data is automatically written into
36 : ! the concentration array HcoState%Spc(HcoID)%Conc if the source data
37 : ! is marked as being concentration data (i.e. if Dta%IsConc is .TRUE.).
38 : ! The latter is automatically determined by HEMCO based upon the data
39 : ! units.
40 : !\\
41 : !\\
42 : ! All emission calculation settings are passed through the HcoState
43 : ! options object (HcoState%Options). These include:
44 : !
45 : ! \begin{itemize}
46 : ! \item ExtNr: extension number to be considered.
47 : ! \item SpcMin: lower species ID (HEMCO ID) to be considered.
48 : ! \item SpcMax: upper species ID (HEMCO ID) to be considered. If set
49 : ! to -1, all species above or equal to SpcMin are considered.
50 : ! \item CatMin: lower emission category to be considered.
51 : ! \item CatMax: upper emission category to be considered. If set to
52 : ! -1, all categories above or equal to CatMin are considered.
53 : ! \item FillBuffer: if set to TRUE, the emissions will be written into
54 : ! buffer array HcoState%Buffer3D instead of HcoState%Spc(ID)%Emis.
55 : ! If this option is enabled, only one species can be calculated at
56 : ! a time (by setting SpcMin/SpcMax, CatMin/CatMax and/or ExtNr
57 : ! accordingly). This option is useful for extensions, e.g. if
58 : ! additional scalings need to be done on some emission fields
59 : ! assembled by HEMCO (e.g. PARANOX extension).
60 : ! \end{itemize}
61 : !
62 : ! !INTERFACE:
63 : !
64 : MODULE HCO_Calc_Mod
65 : !
66 : ! !USES:
67 : !
68 : USE HCO_Diagn_Mod
69 : USE HCO_Error_Mod
70 : USE HCO_Types_Mod
71 : USE HCO_DataCont_Mod, ONLY : Pnt2DataCont
72 :
73 : IMPLICIT NONE
74 : PRIVATE
75 : !
76 : ! !PUBLIC MEMBER FUNCTIONS:
77 : !
78 : PUBLIC :: HCO_CalcEmis
79 : PUBLIC :: HCO_CheckDepv
80 : PUBLIC :: HCO_EvalFld
81 : PUBLIC :: HCO_MaskFld
82 : #ifdef ADJOINT
83 : PUBLIC :: GET_CURRENT_EMISSIONS_ADJ
84 : #endif
85 : !
86 : ! !PRIVATE MEMBER FUNCTIONS:
87 : !
88 : PRIVATE :: GET_CURRENT_EMISSIONS
89 : PRIVATE :: GetMaskVal
90 : PRIVATE :: GetDilFact
91 : PRIVATE :: GetVertIndx
92 : PRIVATE :: GetIdx
93 : !
94 : ! !PARAMETER
95 : !
96 : ! Mask threshold. All mask values below this value will be evaluated
97 : ! as zero (= outside of mask), and all values including and above this
98 : ! value as inside the mask. This is only of relevance if the MaskFractions
99 : ! option is false. If MaskFractions is true, the fractional mask values are
100 : ! considered, e.g. a grid box can contribute 40% to a mask region, etc.
101 : ! The MaskFractions toggle can be set in the settings section of the HEMCO
102 : ! configuration file (Use mask fractions: true/false). It defaults to false.
103 : REAL(sp), PARAMETER :: MASK_THRESHOLD = 0.5_sp
104 : !
105 : ! ============================================================================
106 : !
107 : ! !REVISION HISTORY:
108 : ! 25 Aug 2012 - C. Keller - Initial version.
109 : ! See https://github.com/geoschem/hemco for complete history
110 : !EOP
111 : !------------------------------------------------------------------------------
112 : !BOC
113 : INTERFACE HCO_EvalFld
114 : MODULE PROCEDURE HCO_EvalFld_2D
115 : MODULE PROCEDURE HCO_EvalFld_3D
116 : END INTERFACE HCO_EvalFld
117 :
118 : CONTAINS
119 : !EOC
120 : !------------------------------------------------------------------------------
121 : ! Harmonized Emissions Component (HEMCO) !
122 : !------------------------------------------------------------------------------
123 : !BOP
124 : !
125 : ! !IROUTINE: HCO_CalcEmis
126 : !
127 : ! !DESCRIPTION: Subroutine HCO\_CalcEmis calculates the 3D emission
128 : ! fields at current datetime for the specified species, categories, and
129 : ! extension number.
130 : !\\
131 : !\\
132 : ! !INTERFACE:
133 : !
134 0 : SUBROUTINE HCO_CalcEmis( HcoState, UseConc, RC )
135 : !
136 : ! !USES:
137 : !
138 : USE HCO_STATE_MOD, ONLY : HCO_State
139 : USE HCO_ARR_MOD, ONLY : HCO_ArrAssert
140 : USE HCO_DATACONT_MOD, ONLY : ListCont_NextCont
141 : USE HCO_FILEDATA_MOD, ONLY : FileData_ArrIsDefined
142 : USE HCO_Scale_Mod, ONLY : HCO_ScaleArr
143 : !
144 : ! !INPUT PARAMETERS:
145 : !
146 : LOGICAL, INTENT(IN ) :: UseConc ! Use concentration fields?
147 : !
148 : ! !INPUT/OUTPUT PARAMETERS:
149 : !
150 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
151 : INTEGER, INTENT(INOUT) :: RC ! Return code
152 : !
153 : ! !REVISION HISTORY:
154 : ! 25 Aug 2012 - C. Keller - Initial Version
155 : ! See https://github.com/geoschem/hemco for complete history
156 : !EOP
157 : !------------------------------------------------------------------------------
158 : !BOC
159 : !
160 : ! !LOCAL VARIABLES:
161 : !
162 : ! Working pointers: list and data container
163 : TYPE(ListCont), POINTER :: Lct
164 : TYPE(DataCont), POINTER :: Dct
165 :
166 : ! Temporary emission arrays
167 : REAL(hp), POINTER :: OutArr(:,:,:) => NULL()
168 : REAL(hp), TARGET :: SpcFlx( HcoState%NX, &
169 : HcoState%NY, &
170 0 : HcoState%NZ )
171 : REAL(hp), TARGET :: CatFlx( HcoState%NX, &
172 : HcoState%NY, &
173 0 : HcoState%NZ )
174 : REAL(hp), TARGET :: TmpFlx( HcoState%NX, &
175 : HcoState%NY, &
176 0 : HcoState%NZ )
177 : REAL(hp) :: Mask ( HcoState%NX, &
178 : HcoState%NY, &
179 0 : HcoState%NZ )
180 : REAL(hp) :: HirFlx( HcoState%NX, &
181 : HcoState%NY, &
182 0 : HcoState%NZ )
183 : REAL(hp) :: HirMsk( HcoState%NX, &
184 : HcoState%NY, &
185 0 : HcoState%NZ )
186 :
187 : ! Integers
188 : INTEGER :: ThisSpc, PrevSpc ! current and previous species ID
189 : INTEGER :: ThisCat, PrevCat ! current and previous category
190 : INTEGER :: ThisHir, PrevHir ! current and previous hierarchy
191 : INTEGER :: SpcMin, SpcMax ! range of species to be considered
192 : INTEGER :: CatMin, CatMax ! range of categories to be considered
193 : INTEGER :: ExtNr ! Extension Nr to be used
194 : INTEGER :: nI, nJ, nL
195 : INTEGER :: nnSpec, FLAG
196 :
197 : LOGICAL :: Found, DoDiagn, EOL, UpdateCat
198 :
199 : ! For error handling & verbose mode
200 : CHARACTER(LEN=255) :: MSG, LOC
201 :
202 : ! testing / debugging
203 : integer :: ix,iy
204 :
205 : !=================================================================
206 : ! HCO_CalcEmis begins here!
207 : !=================================================================
208 :
209 : ! testing only
210 0 : ix = 30
211 0 : iy = 34
212 :
213 : ! Initialize
214 0 : LOC = 'HCO_CalcEmis (HCO_CALC_MOD.F90)'
215 0 : Lct => NULL()
216 0 : Dct => NULL()
217 :
218 : ! Enter routine
219 0 : CALL HCO_ENTER (HcoState%Config%Err, LOC, RC )
220 0 : IF(RC /= HCO_SUCCESS) RETURN
221 :
222 : !-----------------------------------------------------------------
223 : ! Initialize variables
224 : !-----------------------------------------------------------------
225 :
226 : ! Initialize
227 0 : SpcFlx(:,:,:) = 0.0_hp
228 0 : CatFlx(:,:,:) = 0.0_hp
229 0 : HirFlx(:,:,:) = 0.0_hp
230 0 : HirMsk(:,:,:) = 0.0_hp
231 0 : PrevSpc = -1
232 0 : PrevHir = -1
233 0 : PrevCat = -1
234 0 : nnSpec = 0
235 :
236 : ! Pass emission grid dimensions
237 0 : nI = HcoState%NX
238 0 : nJ = HcoState%NY
239 0 : nL = HcoState%NZ
240 :
241 : ! Pass calculation options
242 0 : SpcMin = HcoState%Options%SpcMin !Lower species ID
243 0 : SpcMax = HcoState%Options%SpcMax !Upper species ID
244 0 : CatMin = HcoState%Options%CatMin !Lower emission category
245 0 : CatMax = HcoState%Options%CatMax !Upper emission category
246 0 : ExtNr = HcoState%Options%ExtNr !Extension number
247 0 : DoDiagn = HcoState%Options%AutoFillDiagn !Write AutoFill diagnostics?
248 :
249 : ! Verbose mode
250 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
251 0 : WRITE (MSG, *) 'Run HEMCO calculation w/ following options:'
252 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
253 0 : WRITE (MSG, "(A20,I5)") 'Extension number:', ExtNr
254 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
255 0 : WRITE (MSG, "(A20,I5,I5)") 'Tracer range:', SpcMin, SpcMax
256 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
257 0 : WRITE (MSG, "(A20,I5,I5)") 'Category range:', CatMin, CatMax
258 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
259 0 : WRITE (MSG, *) 'Auto diagnostics: ', DoDiagn
260 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
261 : ENDIF
262 :
263 : !=================================================================
264 : ! Walk through all containers of EmisList and determine the
265 : ! emissions for all containers that qualify for calculation.
266 : ! The containers in EmisList are sorted by species, category and
267 : ! hierarchy. This enables a straightforward, piece-by-piece
268 : ! assembly of the final emission array (start with lowest
269 : ! hierarchy emissions, then overwrite piece-by-piece with higher
270 : ! hierarchy values).
271 : !=================================================================
272 :
273 : ! Point to the head of the emissions linked list
274 0 : EOL = .FALSE. ! End of list
275 0 : Lct => NULL()
276 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
277 :
278 : ! Do until end of EmisList (==> loop over all emission containers)
279 : DO
280 : ! Have we reached the end of the list?
281 0 : IF ( FLAG /= HCO_SUCCESS ) THEN
282 : EOL = .TRUE.
283 : ELSE
284 : EOL = .FALSE.
285 : ENDIF
286 :
287 : ! ------------------------------------------------------------
288 : ! Select container and update all working variables & arrays.
289 : ! ------------------------------------------------------------
290 : IF ( .NOT. EOL ) THEN
291 :
292 : ! Dct is the current data container
293 0 : Dct => Lct%Dct
294 :
295 : ! Check if this is a base field
296 0 : IF ( Dct%DctType /= HCO_DCTTYPE_BASE ) THEN
297 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
298 0 : CYCLE
299 : ENDIF
300 :
301 : ! Sanity check: Make sure this container holds data.
302 : ! 'Empty' containers are possible if the simulation time
303 : ! is outside of the specified data time range and time
304 : ! slice cycling is deactivated (CycleFlag > 1).
305 0 : IF( .NOT. FileData_ArrIsDefined(Lct%Dct%Dta) ) THEN
306 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
307 0 : CYCLE
308 : ENDIF
309 :
310 : ! Check if this is the specified extension number
311 0 : IF ( Dct%ExtNr /= ExtNr ) THEN
312 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
313 0 : CYCLE
314 : ENDIF
315 :
316 : ! Advance to next container if the species ID is outside
317 : ! the specified species range (SpcMin - SpcMax). Consider
318 : ! all species above SpcMin if SpcMax is negative!
319 0 : IF( ( Dct%HcoID < SpcMin ) .OR. &
320 : ( (Dct%HcoID > SpcMax) .AND. (SpcMax > 0) ) ) THEN
321 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
322 0 : CYCLE
323 : ENDIF
324 :
325 : ! Advance to next emission field if the emission category of
326 : ! the current container is outside of the specified species
327 : ! range (CatMin - CatMax). Consider all categories above CatMin
328 : ! if CatMax is negative!
329 0 : IF( ( Dct%Cat < CatMin ) .OR. &
330 : ( (Dct%Cat > CatMax) .AND. (CatMax > 0) ) ) THEN
331 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
332 0 : CYCLE
333 : ENDIF
334 :
335 : ! Check if this container holds data in the desired unit format,
336 : ! i.e. concentration data if UseConc is enabled, emission data
337 : ! otherwise.
338 0 : IF ( UseConc .NEQV. Dct%Dta%IsConc ) THEN
339 0 : CALL ListCont_NextCont ( HcoState%EmisList, Lct, FLAG )
340 0 : CYCLE
341 : ENDIF
342 :
343 : ! Update working variables
344 0 : ThisSpc = Dct%HcoID
345 0 : ThisCat = Dct%Cat
346 0 : ThisHir = Dct%Hier
347 :
348 : ! If end of list, use dummy values for ThisSpc, ThisCat and ThisHir
349 : ! to make sure that emissions are added to HEMCO in the section
350 : ! below!
351 : ELSE
352 0 : ThisSpc = -1
353 0 : ThisCat = -1
354 0 : ThisHir = -1
355 : ENDIF
356 :
357 : !--------------------------------------------------------------------
358 : ! Before computing emissions of current data container make sure that
359 : ! emissions of previous container are properly archived.
360 : !--------------------------------------------------------------------
361 :
362 : ! Add emissions on hierarchy level to the category flux array. Do
363 : ! this only if this is a new species, a new category or a new
364 : ! hierarchy level.
365 : ! Note: no need to add to diagnostics because hierarchy level
366 : ! diagnostics are filled right after computing the emissions of
367 : ! a given data container (towards the end of the DO loop).
368 : IF ( (ThisHir /= PrevHir) .OR. &
369 0 : (ThisSpc /= PrevSpc) .OR. &
370 : (ThisCat /= PrevCat) ) THEN
371 :
372 : ! Add hierarchy level emissions to category array over the
373 : ! covered regions.
374 0 : CatFlx = ( (1.0_hp - HirMsk) * CatFlx ) + HirFlx
375 :
376 : ! Reset
377 0 : HirFlx = 0.0_hp
378 0 : HirMsk = 0.0_hp
379 : ENDIF
380 :
381 : !--------------------------------------------------------------------
382 : ! If this is a new species or category, pass the previously collected
383 : ! emissions to the species array. Update diagnostics at category level.
384 : ! Skip this step for first species, i.e. if PrevSpc is still -1.
385 : !--------------------------------------------------------------------
386 0 : UpdateCat = .FALSE.
387 0 : IF ( ThisCat /= PrevCat ) UpdateCat = .TRUE.
388 0 : IF ( ThisSpc /= PrevSpc ) UpdateCat = .TRUE.
389 0 : IF ( PrevCat <= 0 .OR. PrevSpc <= 0 ) UpdateCat = .FALSE.
390 0 : IF ( UpdateCat ) THEN
391 :
392 : ! CatFlx holds the emissions for this category. Pass this to
393 : ! the species array SpcFlx.
394 0 : SpcFlx(:,:,:) = SpcFlx(:,:,:) + CatFlx(:,:,:)
395 :
396 : ! verbose
397 0 : IF ( HCO_IsVerb(HcoState%Config%Err,3) ) THEN
398 0 : WRITE(MSG,*) 'Added category emissions to species array: '
399 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
400 0 : WRITE(MSG,*) 'Species : ', PrevSpc
401 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
402 0 : WRITE(MSG,*) 'Category : ', PrevCat
403 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
404 0 : WRITE(MSG,*) 'Cat. emissions: ', SUM(CatFlx)
405 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
406 0 : WRITE(MSG,*) 'Spc. emissions: ', SUM(SpcFlx)
407 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
408 : ENDIF
409 :
410 : ! Add category emissions to diagnostics at category level
411 : ! (only if defined in the diagnostics list).
412 0 : IF ( Diagn_AutoFillLevelDefined(HcoState%Diagn,3) .AND. DoDiagn ) THEN
413 : ! Bug fix: Make sure to pass COL=-1 to ensure all HEMCO diagnostics
414 : ! are updated, including those manually defined in other models
415 : ! (mps, 11/30/21)
416 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
417 : Cat=PrevCat, Hier=-1, HcoID=PrevSpc, &
418 0 : AutoFill=1, Array3D=CatFlx, COL=-1, RC=RC )
419 0 : IF ( RC /= HCO_SUCCESS ) THEN
420 0 : CALL HCO_ERROR( 'ERROR 0', RC, THISLOC=LOC )
421 0 : RETURN
422 : ENDIF
423 : #ifdef ADJOINT
424 : IF (HcoState%IsAdjoint) THEN
425 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
426 : Cat=PrevCat, Hier=-1, HcoID=PrevSpc, &
427 : AutoFill=1, Array3D=CatFlx, &
428 : COL=HcoState%Diagn%HcoDiagnIDAdjoint, RC=RC )
429 : IF ( RC /= HCO_SUCCESS ) THEN
430 : CALL HCO_ERROR( 'ERROR 1', RC, THISLOC=LOC )
431 : RETURN
432 : ENDIF
433 : ENDIF
434 : #endif
435 : ENDIF
436 :
437 : ! Reset CatFlx array and the previously used hierarchy
438 : ! ==> Emission hierarchies are only important within the
439 : ! same category, hence always start over at lowest hierarchy
440 : ! when entering a new category.
441 0 : CatFlx(:,:,:) = 0.0_hp
442 : PrevHir = -1
443 : ENDIF
444 :
445 : !--------------------------------------------------------------------
446 : ! If this is a new species, pass previously calculated emissions
447 : ! to the final emissions array in HcoState.
448 : ! Update diagnostics at extension number level.
449 : ! Don't do before first emission calculation, i.e. if PrevSpc
450 : ! is still the initialized value of -1!
451 : !--------------------------------------------------------------------
452 0 : IF ( ThisSpc /= PrevSpc .AND. PrevSpc > 0 ) THEN
453 :
454 : ! Add to OutArr
455 0 : OutArr(:,:,:) = OutArr(:,:,:) + SpcFlx(:,:,:)
456 :
457 : ! testing only
458 0 : IF ( HCO_IsVerb(HcoState%Config%Err,3) ) THEN
459 0 : WRITE(MSG,*) 'Added total emissions to output array: '
460 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
461 0 : WRITE(MSG,*) 'Species: ', PrevSpc
462 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
463 0 : WRITE(MSG,*) 'SpcFlx : ', SUM(SpcFlx)
464 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
465 0 : WRITE(MSG,*) 'OutArr : ', SUM(OutArr)
466 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
467 : ENDIF
468 :
469 : ! Add to diagnostics at extension number level.
470 : ! The same diagnostics may be updated multiple times during
471 : ! the same time step, continuously adding emissions to it.
472 0 : IF ( Diagn_AutoFillLevelDefined(HcoState%Diagn,2) .AND. DoDiagn ) THEN
473 : ! Bug fix: Make sure to pass COL=-1 to ensure all HEMCO diagnostics
474 : ! are updated, including those manually defined in other models
475 : ! (mps, 11/30/21)
476 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
477 : Cat=-1, Hier=-1, HcoID=PrevSpc, &
478 0 : AutoFill=1,Array3D=SpcFlx, COL=-1, RC=RC )
479 0 : IF ( RC /= HCO_SUCCESS ) THEN
480 0 : CALL HCO_ERROR( 'ERROR 2', RC, THISLOC=LOC )
481 0 : RETURN
482 : ENDIF
483 : #ifdef ADJOINT
484 : IF (HcoState%IsAdjoint) THEN
485 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
486 : Cat=-1, Hier=-1, HcoID=PrevSpc, &
487 : AutoFill=1,Array3D=SpcFlx, &
488 : COL=HcoState%Diagn%HcoDiagnIDAdjoint, RC=RC )
489 : IF ( RC /= HCO_SUCCESS ) THEN
490 : CALL HCO_ERROR( 'ERROR 3', RC, THISLOC=LOC )
491 : RETURN
492 : ENDIF
493 : ENDIF
494 : #endif
495 : ENDIF
496 :
497 : ! Reset arrays and previous hierarchy.
498 0 : SpcFlx(:,:,:) = 0.0_hp
499 0 : PrevCat = -1
500 0 : PrevHir = -1
501 0 : OutArr => NULL()
502 : ENDIF
503 :
504 : !--------------------------------------------------------------------
505 : ! Exit DO loop here if end of list
506 : !--------------------------------------------------------------------
507 0 : IF ( EOL ) EXIT
508 :
509 : !--------------------------------------------------------------------
510 : ! Update/archive information on species level if needed
511 : !--------------------------------------------------------------------
512 0 : IF ( ThisSpc /= PrevSpc .AND. ThisSpc > 0 ) THEN
513 :
514 : ! Update number of species for which emissions have been
515 : ! calculated.
516 0 : nnSpec = nnSpec + 1
517 :
518 : ! To write emissions into temporary array, make OutArr point
519 : ! to the buffer array HcoState%Buffer3D.
520 0 : IF ( HcoState%Options%FillBuffer ) THEN
521 :
522 : ! Cannot use temporary array for more than one species!
523 0 : IF ( nnSpec > 1 ) THEN
524 0 : MSG = 'Cannot fill buffer for more than one species!'
525 0 : CALL HCO_ERROR( MSG, RC )
526 0 : RETURN
527 : ENDIF
528 :
529 : ! Point to array and check allocation status as well as
530 : ! array size.
531 0 : OutArr => HcoState%Buffer3D%Val
532 0 : IF ( .NOT. ASSOCIATED( OutArr ) ) THEN
533 0 : MSG = 'Buffer array is not associated'
534 0 : CALL HCO_ERROR( MSG, RC )
535 0 : RETURN
536 : ENDIF
537 : IF ( (SIZE(OutArr,1) /= nI) .OR. &
538 0 : (SIZE(OutArr,2) /= nJ) .OR. &
539 : (SIZE(OutArr,3) /= nL) ) THEN
540 0 : MSG = 'Buffer array has wrong dimension!'
541 0 : CALL HCO_ERROR( MSG, RC )
542 0 : RETURN
543 : ENDIF
544 :
545 : ! To write emissions directly into HcoState, make OutArr
546 : ! point to current species' array in HcoState. Use emission
547 : ! array for emissions, and concentration array for concentrations.
548 : ELSE
549 :
550 : ! For concentrations:
551 0 : IF ( UseConc ) THEN
552 0 : CALL HCO_ArrAssert( HcoState%Spc(ThisSpc)%Conc, &
553 0 : nI, nJ, nL, RC )
554 0 : IF ( RC /= HCO_SUCCESS ) THEN
555 0 : CALL HCO_ERROR( 'ERROR 4', RC, THISLOC=LOC )
556 0 : RETURN
557 : ENDIF
558 0 : OutArr => HcoState%Spc(ThisSpc)%Conc%Val
559 :
560 : ! For emissions:
561 : ELSE
562 0 : CALL HCO_ArrAssert( HcoState%Spc(ThisSpc)%Emis, &
563 0 : nI, nJ, nL, RC )
564 0 : IF ( RC /= HCO_SUCCESS ) THEN
565 0 : CALL HCO_ERROR( 'ERROR 5', RC, THISLOC=LOC )
566 0 : RETURN
567 : ENDIF
568 0 : OutArr => HcoState%Spc(ThisSpc)%Emis%Val
569 : ENDIF
570 :
571 : ENDIF
572 :
573 : ! verbose mode
574 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
575 0 : WRITE(MSG,*) 'Calculating emissions for species ', &
576 0 : TRIM(HcoState%Spc(ThisSpc)%SpcName)
577 0 : CALL HCO_MSG( HcoState%Config%Err, MSG, SEP1='-', SEP2='-' )
578 : ENDIF
579 : ENDIF
580 :
581 : !--------------------------------------------------------------------
582 : ! Get current emissions and write into TmpFlx array. The array Mask
583 : ! denotes all valid grid boxes for this inventory.
584 : !--------------------------------------------------------------------
585 0 : TmpFlx(:,:,:) = 0.0_hp
586 0 : CALL GET_CURRENT_EMISSIONS( HcoState, Dct, nI, nJ, nL, TmpFlx, Mask, RC )
587 0 : IF ( RC /= HCO_SUCCESS ) THEN
588 0 : CALL HCO_ERROR( 'ERROR 6', RC, THISLOC=LOC )
589 0 : RETURN
590 : ENDIF
591 :
592 : ! Eventually add universal scale factor
593 0 : CALL HCO_ScaleArr( HcoState, ThisSpc, TmpFlx, RC )
594 0 : IF ( RC /= HCO_SUCCESS ) THEN
595 0 : CALL HCO_ERROR( 'ERROR 7', RC, THISLOC=LOC )
596 0 : RETURN
597 : ENDIF
598 :
599 : ! Check for negative values according to the corresponding setting
600 : ! in the configuration file: 2 means allow negative values, 1 means
601 : ! set to zero and prompt a warning, else return with error.
602 0 : IF ( HcoState%Options%NegFlag /= 2 ) THEN
603 :
604 0 : IF ( ANY(TmpFlx < 0.0_hp) ) THEN
605 :
606 : ! Set to zero and prompt warning
607 0 : IF ( HcoState%Options%NegFlag == 1 ) THEN
608 0 : WHERE ( TmpFlx < 0.0_hp ) TmpFlx = 0.0_hp
609 0 : MSG = 'Negative emissions set to zero: '// TRIM(Dct%cName)
610 0 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC )
611 :
612 : ! Return with error
613 : ELSE
614 : MSG = 'Negative emissions in: '// TRIM(Dct%cName) // '. ' // &
615 0 : 'To allow negatives, edit settings in the configuration file.'
616 0 : CALL HCO_ERROR( MSG, RC )
617 0 : RETURN
618 : ENDIF
619 : ENDIF
620 : ENDIF
621 :
622 : ! ------------------------------------------------------------
623 : ! Collect all emissions of the same category (and species) on
624 : ! the hierarchy level into array HirFlx. HirMsk contains the
625 : ! combined covered region. That is, if there are two regional
626 : ! inventories with the same hierarchy HirMsk will cover both
627 : ! of these regions.
628 : ! The specified field hierarchies determine whether the
629 : ! temporary emissions are added (if hierarchy is the same
630 : ! as the previously used hierarchy), or if they overwrite the
631 : ! previous values in HirFlx (if hierarchy is higher than the
632 : ! previous hierarchy).
633 : ! ------------------------------------------------------------
634 :
635 : ! Add emissions to the hierarchy array HirFlx if this hierarchy
636 : ! is the same as previous hierarchy
637 0 : IF ( ThisHir == PrevHir ) THEN
638 0 : HirFlx = HirFlx + TmpFlx
639 0 : HirMsk = HirMsk + Mask
640 :
641 : ! Make sure mask values do not exceed 1.0
642 0 : WHERE(HirMsk > 1.0 ) HirMsk = 1.0
643 :
644 : ! If hierarchy is larger than those of the previously used
645 : ! fields, overwrite HirFlx with new values.
646 : ELSE
647 :
648 0 : HirFlx = TmpFlx
649 0 : HirMsk = Mask
650 :
651 : ENDIF
652 :
653 : ! Update diagnostics at hierarchy level. Make sure that only
654 : ! positive values are used.
655 : ! The same diagnostics may be updated multiple times
656 : ! during the same time step, continuously adding
657 : ! emissions to it.
658 : ! Now remove PosOnly flag. TmpFlx is initialized to zero, so it's
659 : ! ok to keep negative values (ckeller, 7/12/15).
660 0 : IF ( Diagn_AutoFillLevelDefined(HcoState%Diagn,4) .AND. DoDiagn ) THEN
661 : ! Bug fix: Make sure to pass COL=-1 to ensure all HEMCO diagnostics
662 : ! are updated, including those manually defined in other models
663 : ! (mps, 11/30/21)
664 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
665 : Cat=ThisCat,Hier=ThisHir, HcoID=ThisSpc, &
666 : AutoFill=1, Array3D=TmpFlx, &
667 0 : COL=-1, RC=RC )
668 0 : IF ( RC /= HCO_SUCCESS ) THEN
669 0 : CALL HCO_ERROR( 'ERROR 8', RC, THISLOC=LOC )
670 0 : RETURN
671 : ENDIF
672 : #ifdef ADJOINT
673 : IF (HcoState%IsAdjoint) THEN
674 : ! I don't know why I chose collection=-1 instead of
675 : ! collection=HcoState%Diagn%HcoDiagnIDAdjoint like in the other
676 : ! parts of the adjoint code here, but it's what worked in the
677 : ! old repo so I'm keeping it for now. May need to change
678 : CALL Diagn_Update( HcoState, ExtNr=ExtNr, &
679 : Cat=ThisCat,Hier=ThisHir, HcoID=ThisSpc, &
680 : AutoFill=1, Array3D=TmpFlx, &
681 : COL=-1, RC=RC )
682 : IF ( RC /= HCO_SUCCESS ) THEN
683 : CALL HCO_ERROR( 'ERROR 9', RC, THISLOC=LOC )
684 : RETURN
685 : ENDIF
686 : ENDIF
687 :
688 : #endif
689 : ENDIF
690 :
691 : ! Update previously used species, category and hierarchy
692 0 : PrevSpc = ThisSpc
693 0 : PrevCat = ThisCat
694 0 : PrevHir = ThisHir
695 :
696 : ! Advance to next emission container
697 0 : CALL ListCont_NextCont( HcoState%EmisList, Lct, FLAG )
698 :
699 : ENDDO ! Loop over EmisList
700 :
701 : ! Make sure internal pointers are nullified
702 0 : Lct => NULL()
703 0 : Dct => NULL()
704 0 : OutArr => NULL()
705 :
706 : ! verbose
707 0 : IF ( HCO_IsVerb(HcoState%Config%Err,1) ) THEN
708 0 : WRITE (MSG, *) 'HEMCO emissions successfully calculated!'
709 0 : CALL HCO_MSG ( HcoState%Config%Err, MSG )
710 : ENDIF
711 :
712 : ! Leave w/ success
713 0 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
714 :
715 : END SUBROUTINE HCO_CalcEmis
716 : !EOC
717 : !------------------------------------------------------------------------------
718 : ! Harmonized Emissions Component (HEMCO) !
719 : !------------------------------------------------------------------------------
720 : !BOP
721 : !
722 : ! !IROUTINE: HCO_CheckDepv
723 : !
724 : ! !DESCRIPTION: Subroutine HCO\_CheckDepv is a simple routine to check the
725 : ! dry deposition frequency value. This is to avoid unrealistically high
726 : ! deposition frequencies that may occur if grid box concentrations are very
727 : ! low. The deposition frequency is limited to a value that will make sure
728 : ! that the drydep exponent ( exp( -depfreq * dt ) ) is still small enough to
729 : ! remove all species mass. The maximum limit of depfreq * dt can be defined
730 : ! as a HEMCO option (MaxDepExp). Its default value is 20.0.
731 : !\\
732 : !\\
733 : ! !INTERFACE:
734 : !
735 0 : SUBROUTINE HCO_CheckDepv( HcoState, Depv, RC )
736 : !
737 : ! !USES:
738 : !
739 : USE HCO_STATE_MOD, ONLY : HCO_State
740 : !
741 : ! !INPUT/OUTPUT PARAMETERS:
742 : !
743 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
744 : REAL(hp), INTENT(INOUT) :: Depv ! Deposition velocity
745 : INTEGER, INTENT(INOUT) :: RC ! Return code
746 : !
747 : ! !REVISION HISTORY:
748 : ! 11 Mar 2015 - C. Keller - Initial Version
749 : ! See https://github.com/geoschem/hemco for complete history
750 : !EOP
751 : !------------------------------------------------------------------------------
752 : !BOC
753 : !
754 : ! !LOCAL VARIABLES:
755 : !
756 : REAL(hp) :: ExpVal
757 :
758 : !=================================================================
759 : ! HCO_CheckDepv begins here!
760 : !=================================================================
761 :
762 0 : ExpVal = Depv * HcoState%TS_EMIS
763 0 : IF ( ExpVal > HcoState%Options%MaxDepExp ) THEN
764 0 : Depv = HcoState%Options%MaxDepExp / HcoState%TS_EMIS
765 : ENDIF
766 :
767 0 : END SUBROUTINE HCO_CheckDepv
768 : !EOC
769 : !------------------------------------------------------------------------------
770 : ! Harmonized Emissions Component (HEMCO) !
771 : !------------------------------------------------------------------------------
772 : !BOP
773 : !
774 : ! !IROUTINE: Get_Current_Emissions
775 : !
776 : ! !DESCRIPTION: Subroutine Get\_Current\_Emissions calculates the current
777 : ! emissions for the specified emission container.
778 : ! This subroutine is only called by HCO\_CalcEmis and for base emission
779 : ! containers, i.e. containers of type 1.
780 : !\\
781 : !\\
782 : ! !INTERFACE:
783 : !
784 0 : SUBROUTINE Get_Current_Emissions( HcoState, BaseDct, nI, nJ, &
785 0 : nL, OUTARR_3D, MASK, RC, UseLL )
786 : !
787 : ! !USES:
788 : !
789 : USE HCO_State_Mod, ONLY : HCO_State
790 : USE HCO_tIdx_MOD, ONLY : tIDx_GetIndx
791 : USE HCO_FileData_Mod, ONLY : FileData_ArrIsDefined
792 : !
793 : ! !INPUT PARAMETERS:
794 : !
795 : INTEGER, INTENT(IN) :: nI ! # of lons
796 : INTEGER, INTENT(IN) :: nJ ! # of lats
797 : INTEGER, INTENT(IN) :: nL ! # of levs
798 : !
799 : ! !INPUT/OUTPUT PARAMETERS:
800 : !
801 :
802 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
803 : TYPE(DataCont), POINTER :: BaseDct ! base emission
804 : ! container
805 : REAL(hp), INTENT(INOUT) :: OUTARR_3D(nI,nJ,nL) ! output array
806 : REAL(hp), INTENT(INOUT) :: MASK (nI,nJ,nL) ! mask array
807 : INTEGER, INTENT(INOUT) :: RC
808 : !
809 : ! !OUTPUT PARAMETERS:
810 : !
811 : INTEGER, INTENT( OUT), OPTIONAL :: UseLL
812 : !
813 : ! !REMARKS:
814 : ! This routine uses multiple loops over all grid boxes (base emissions
815 : ! and scale factors use separate loops). In an OMP environment, this approach
816 : ! seems to be faster than using only one single loop (but repeated calls to
817 : ! point to containers, etc.). The alternative approach is used in routine
818 : ! Get\_Current\_Emissions\_B at the end of this module and may be employed
819 : ! on request.
820 : !
821 : ! !REVISION HISTORY:
822 : ! 25 Aug 2012 - C. Keller - Initial Version
823 : ! See https://github.com/geoschem/hemco for complete history
824 : !EOP
825 : !------------------------------------------------------------------------------
826 : !BOC
827 : !
828 : ! !LOCAL VARIABLES:
829 : !
830 : ! Pointers
831 : TYPE(DataCont), POINTER :: ScalDct
832 : TYPE(DataCont), POINTER :: MaskDct
833 : TYPE(DataCont), POINTER :: LevDct1
834 : TYPE(DataCont), POINTER :: LevDct2
835 :
836 : ! Scalars
837 : REAL(sp) :: TMPVAL, MaskScale
838 : REAL(hp) :: DilFact
839 : REAL(hp) :: ScalFact
840 : INTEGER :: tIDx, IDX
841 : INTEGER :: totLL, nnLL
842 : INTEGER :: I, J, L, N
843 : INTEGER :: LowLL, UppLL, ScalLL, TmpLL
844 : INTEGER :: ERROR
845 : CHARACTER(LEN=255) :: MSG, LOC
846 : LOGICAL :: NegScalExist
847 : LOGICAL :: MaskFractions
848 : LOGICAL :: isLevDct1
849 : LOGICAL :: isLevDct2
850 : LOGICAL :: isMaskDct
851 : LOGICAL :: isPblHt
852 : LOGICAL :: isBoxHt
853 : INTEGER :: LevDct1_Unit
854 : INTEGER :: LevDct2_Unit
855 :
856 : ! testing only
857 : INTEGER, PARAMETER :: IX=25, IY=25
858 :
859 : !=================================================================
860 : ! GET_CURRENT_EMISSIONS begins here
861 : !=================================================================
862 :
863 : ! Initialize
864 0 : ScalDct => NULL()
865 0 : MaskDct => NULL()
866 0 : LOC = 'GET_CURRENT_EMISSIONS (hco_calc_mod.F90)'
867 :
868 : ! Enter
869 0 : CALL HCO_ENTER(HcoState%Config%Err, LOC, RC )
870 0 : IF(RC /= HCO_SUCCESS) RETURN
871 :
872 : ! Check if container contains data
873 0 : IF ( .NOT. FileData_ArrIsDefined(BaseDct%Dta) ) THEN
874 0 : MSG = 'Array not defined: ' // TRIM(BaseDct%cName)
875 0 : CALL HCO_ERROR( MSG, RC )
876 0 : RETURN
877 : ENDIF
878 :
879 : ! Initialize mask. By default, assume that we use all grid boxes.
880 0 : MASK(:,:,:) = 1.0_hp
881 0 : MaskFractions = HcoState%Options%MaskFractions
882 :
883 : ! Verbose
884 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
885 0 : WRITE(MSG,*) 'Evaluate field ', TRIM(BaseDct%cName)
886 0 : CALL HCO_MSG(HcoState%Config%Err,MSG,SEP1=' ')
887 : ENDIF
888 :
889 : ! Put check for PBLHEIGHT here (bmy, 3/4/21)
890 : #if !defined ( ESMF_ )
891 0 : IF ( .NOT. ASSOCIATED(HcoState%Grid%PBLHEIGHT%Val) ) THEN
892 0 : MSG = 'PBLHEIGHT (in meters) is missing in HEMCO state'
893 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
894 0 : RETURN
895 : ENDIF
896 : #endif
897 :
898 : ! ----------------------------------------------------------------
899 : ! Set base emissions
900 : ! ----------------------------------------------------------------
901 :
902 : ! Initialize ERROR. Will be set to 1 if error occurs below
903 0 : ERROR = 0
904 :
905 : ! Initialize variables to compute average vertical level index
906 0 : totLL = 0.0
907 0 : nnLL = 0.0
908 :
909 : !-----------------------------------------------------------------
910 : ! Check for level index containers
911 : ! Move error checks here, outside of the parallel DO loop
912 : !-----------------------------------------------------------------
913 0 : IF ( BaseDct%levScalID1 > 0 ) THEN
914 0 : CALL Pnt2DataCont( HcoState, BaseDct%levScalID1, LevDct1, RC )
915 0 : IF ( RC /= HCO_SUCCESS ) THEN
916 0 : CALL HCO_ERROR( 'ERROR 10', RC, THISLOC=LOC )
917 0 : RETURN
918 : ENDIF
919 : ELSE
920 0 : LevDct1 => NULL()
921 : ENDIF
922 0 : IF ( BaseDct%levScalID2 > 0 ) THEN
923 0 : CALL Pnt2DataCont( HcoState, BaseDct%levScalID2, LevDct2, RC )
924 0 : IF ( RC /= HCO_SUCCESS ) THEN
925 0 : CALL HCO_ERROR( 'ERROR 11', RC, THISLOC=LOC )
926 0 : RETURN
927 : ENDIF
928 : ELSE
929 0 : LevDct2 => NULL()
930 : ENDIF
931 :
932 : ! Test whether LevDct1 and LevDct2 are associated
933 0 : isLevDct1 = ASSOCIATED( LevDct1 )
934 0 : isLevDct2 = ASSOCIATED( LevDct2 )
935 :
936 : ! Get the units of LevDct1 (if it exists)
937 0 : IF ( isLevDct1 ) THEN
938 0 : LevDct1_Unit = GetEmisLUnit( HcoState, LevDct1 )
939 0 : IF ( LevDct1_Unit < 0 ) THEN
940 0 : MSG = 'LevDct1 units are not defined!'
941 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
942 0 : RC = HCO_FAIL
943 0 : RETURN
944 : ENDIF
945 : ELSE
946 0 : LevDct1_Unit = -1
947 : ENDIF
948 :
949 : ! Get the units of LevDct2 (if it exists)
950 0 : IF ( isLevDct2 ) THEN
951 0 : LevDct2_Unit = GetEmisLUnit( HcoState, LevDct2 )
952 0 : IF ( LevDct2_Unit < 0 ) THEN
953 0 : MSG = 'LevDct2_Units are not defined!'
954 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
955 0 : RETURN
956 : ENDIF
957 : ELSE
958 0 : LevDct2_Unit = -1
959 : ENDIF
960 :
961 : ! Throw an error if boxheight is missing and the units are in meters
962 0 : IF ( LevDct1_Unit == HCO_EMISL_M .or. &
963 : LevDct2_Unit == HCO_EMISL_M ) THEN
964 0 : IF ( .NOT. ASSOCIATED(HcoState%Grid%BXHEIGHT_M%Val) ) THEN
965 0 : MSG = 'Boxheight (in meters) is missing in HEMCO state'
966 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
967 0 : RETURN
968 : ENDIF
969 : ENDIF
970 :
971 : ! Throw an error if boxheight is missing and the units are in PBL frac
972 0 : IF ( LevDct1_Unit == HCO_EMISL_PBL .or. &
973 : LevDct2_Unit == HCO_EMISL_PBL ) THEN
974 0 : IF ( .NOT. ASSOCIATED(HcoState%Grid%PBLHEIGHT%Val) ) THEN
975 0 : MSG = 'Boundary layer height is missing in HEMCO state'
976 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
977 0 : RETURN
978 : ENDIF
979 : ENDIF
980 :
981 : !------------------------------------------------------------------------
982 : ! Loop over all latitudes and longitudes
983 : !
984 : ! NOTE: It is OK to exit from the "I" loop, because only
985 : ! the "J" loop is being parallelized (bmy, 3/8/21)
986 : !------------------------------------------------------------------------
987 : !$OMP PARALLEL DO &
988 : !$OMP DEFAULT( SHARED ) &
989 : !$OMP PRIVATE( I, J, L, tIdx, TMPVAL, DilFact, LowLL, UppLL )&
990 : !$OMP REDUCTION( +:totLL )&
991 : !$OMP REDUCTION( +:nnLL )
992 0 : DO J = 1, nJ
993 0 : DO I = 1, nI
994 :
995 : ! Zero private variables for safety's sake
996 0 : tmpVal = 0.0_hp
997 0 : dilFact = 0.0_hp
998 0 : lowLL = 0
999 0 : uppLL = 0
1000 :
1001 : ! Get current time index for this container and at this location
1002 0 : tIDx = tIDx_GetIndx( HcoState, BaseDct%Dta, I, J )
1003 0 : IF ( tIDx < 1 ) THEN
1004 0 : WRITE(MSG,*) 'Cannot get time slice index at location ',I,J,&
1005 0 : ': ', TRIM(BaseDct%cName), tIDx
1006 0 : ERROR = 1
1007 0 : EXIT
1008 : ENDIF
1009 :
1010 : ! Get lower and upper vertical index
1011 : CALL GetVertIndx( HcoState, BaseDct, isLevDct1, LevDct1, &
1012 : LevDct1_Unit, isLevDct2, LevDct2, LevDct2_Unit, &
1013 : I, J, LowLL, UppLL, &
1014 0 : RC )
1015 0 : IF ( RC /= HCO_SUCCESS ) THEN
1016 0 : WRITE(MSG,*) 'Error getting vertical index at location ',I,J,&
1017 0 : ': ', TRIM(BaseDct%cName)
1018 0 : ERROR = 1 ! Will cause error
1019 0 : EXIT
1020 : ENDIF
1021 :
1022 : ! Update variables for computing the average level
1023 0 : totLL = totLL + UppLL
1024 0 : nnLL = nnLL + 1
1025 :
1026 : ! Loop over all levels
1027 0 : DO L = LowLL, UppLL
1028 :
1029 : ! Get base value. Use uniform value if scalar field.
1030 0 : IF ( BaseDct%Dta%SpaceDim == 1 ) THEN
1031 0 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(1,1)
1032 0 : ELSEIF ( BaseDct%Dta%SpaceDim == 2 ) THEN
1033 0 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(I,J)
1034 : ELSE
1035 0 : TMPVAL = BaseDct%Dta%V3(tIDx)%Val(I,J,L)
1036 : ENDIF
1037 :
1038 : ! If it's a missing value, mask box as unused and set value to zero
1039 0 : IF ( TMPVAL == HCO_MISSVAL ) THEN
1040 0 : MASK(I,J,:) = 0.0_hp
1041 0 : OUTARR_3D(I,J,L) = 0.0_hp
1042 :
1043 : ! Pass base value to output array
1044 : ELSE
1045 :
1046 : ! Get dilution factor. Never dilute 3D emissions.
1047 0 : IF ( BaseDct%Dta%SpaceDim == 3 ) THEN
1048 0 : DilFact = 1.0_hp
1049 :
1050 : ! If emission level mode is 2, copy emissions to all level
1051 : ! A separate scale factor should be used to distribute vertically
1052 0 : ELSE IF ( BaseDct%Dta%EmisLmode == 2 ) THEN
1053 0 : DilFact = 1.0_hp
1054 :
1055 : ! 2D dilution factor
1056 : ELSE
1057 : CALL GetDilFact( &
1058 : HcoState, BaseDct%Dta%EmisL1, &
1059 : BaseDct%Dta%EmisL1Unit, BaseDct%Dta%EmisL2, &
1060 : BaseDct%Dta%EmisL2Unit, I, &
1061 : J, L, &
1062 : LowLL, UppLL, &
1063 0 : DilFact, RC )
1064 0 : IF ( RC /= HCO_SUCCESS ) THEN
1065 0 : WRITE(MSG,*) 'Error getting dilution factor at ',I,J,&
1066 0 : ': ', TRIM(BaseDct%cName)
1067 0 : ERROR = 1
1068 0 : EXIT
1069 : ENDIF
1070 : ENDIF
1071 :
1072 : ! Scale base emission by dilution factor
1073 0 : OUTARR_3D(I,J,L) = DilFact * TMPVAL
1074 : ENDIF
1075 : ENDDO !L
1076 :
1077 : ENDDO !I
1078 : ENDDO !J
1079 : !$OMP END PARALLEL DO
1080 :
1081 : ! Check for error
1082 0 : IF ( ERROR == 1 ) THEN
1083 0 : CALL HCO_ERROR( MSG, RC )
1084 0 : RETURN
1085 : ENDIF
1086 :
1087 : ! ----------------------------------------------------------------
1088 : ! Apply scale factors
1089 : ! The container IDs of all scale factors associated with this base
1090 : ! container are stored in vector Scal_cID.
1091 : ! ----------------------------------------------------------------
1092 :
1093 : ! Loop over scale factors
1094 0 : IF ( BaseDct%nScalID > 0 ) THEN
1095 :
1096 0 : DO N = 1, BaseDct%nScalID
1097 :
1098 : ! Get the scale factor container ID for the current slot
1099 0 : IDX = BaseDct%Scal_cID(N)
1100 :
1101 : ! Point to data container with the given container ID
1102 0 : CALL Pnt2DataCont( HcoState, IDX, ScalDct, RC )
1103 0 : IF ( RC /= HCO_SUCCESS ) THEN
1104 0 : CALL HCO_ERROR( 'ERROR 12', RC, THISLOC=LOC )
1105 0 : RETURN
1106 : ENDIF
1107 :
1108 : ! Sanity check: scale field cannot be a base field
1109 0 : IF ( (ScalDct%DctType == HCO_DCTTYPE_BASE) ) THEN
1110 0 : MSG = 'Wrong scale field type: ' // TRIM(ScalDct%cName)
1111 0 : CALL HCO_ERROR( MSG, RC )
1112 0 : RETURN
1113 : ENDIF
1114 :
1115 : ! Skip this scale factor if no data defined. This is possible
1116 : ! if scale factors are only defined for a given time range and
1117 : ! the simulation datetime is outside of this range.
1118 0 : IF ( .NOT. FileData_ArrIsDefined(ScalDct%Dta) ) THEN
1119 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
1120 : MSG = 'Skip scale factor '//TRIM(ScalDct%cName)// &
1121 0 : ' because it is not defined for this datetime.'
1122 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1123 : ENDIF
1124 : CYCLE
1125 : ENDIF
1126 :
1127 : ! Verbose mode
1128 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
1129 0 : MSG = 'Applying scale factor ' // TRIM(ScalDct%cName)
1130 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1131 : ENDIF
1132 :
1133 : ! Get vertical extension of this scale factor array.
1134 0 : IF( (ScalDct%Dta%SpaceDim<=2) ) THEN
1135 : ScalLL = 1
1136 : ELSE
1137 0 : ScalLL = SIZE(ScalDct%Dta%V3(1)%Val,3)
1138 : ENDIF
1139 :
1140 : ! Check if there is a mask field associated with this scale
1141 : ! factor. In this case, get a pointer to the corresponding
1142 : ! mask field and evaluate scale factors only inside the mask
1143 : ! region.
1144 0 : IF ( ASSOCIATED(ScalDct%Scal_cID) ) THEN
1145 0 : CALL Pnt2DataCont( HcoState, ScalDct%Scal_cID(1), MaskDct, RC )
1146 0 : IF ( RC /= HCO_SUCCESS ) THEN
1147 0 : CALL HCO_ERROR( 'ERROR 13', RC, THISLOC=LOC )
1148 0 : RETURN
1149 : ENDIF
1150 :
1151 : ! Must be mask field
1152 0 : IF ( MaskDct%DctType /= HCO_DCTTYPE_MASK ) THEN
1153 0 : MSG = 'Invalid mask for scale factor: '//TRIM(ScalDct%cName)
1154 0 : MSG = TRIM(MSG) // '; mask: '//TRIM(MaskDct%cName)
1155 0 : CALL HCO_ERROR( MSG, RC )
1156 0 : RETURN
1157 : ENDIF
1158 : ENDIF
1159 :
1160 : ! Set a flag to denote whether MaskDct is associated
1161 : ! This can be done outside of the parallel loops below
1162 0 : isMaskDct = ASSOCIATED( MaskDct )
1163 :
1164 : ! Reinitialize error flag. Will be set to 1 or 2 if error occurs,
1165 : ! and to -1 if negative scale factor is ignored.
1166 0 : ERROR = 0
1167 :
1168 : !--------------------------------------------------------------------
1169 : ! Loop over all latitudes and longitudes
1170 : !
1171 : ! NOTE: It is OK to CYCLE or EXIT from the "I" loop, because
1172 : ! only the "J" loop is being parallelized (bmy, 3/8/21)
1173 : !--------------------------------------------------------------------
1174 : !$OMP PARALLEL DO &
1175 : !$OMP DEFAULT( SHARED )&
1176 : !$OMP PRIVATE( I, J, tIdx, TMPVAL, L, LowLL, UppLL, tmpLL, MaskScale )
1177 0 : DO J = 1, nJ
1178 0 : DO I = 1, nI
1179 :
1180 : ! ------------------------------------------------------------
1181 : ! If there is a mask associated with this scale factors, check
1182 : ! if this grid box is within or outside of the mask region.
1183 : ! Values that partially fall into the mask region are either
1184 : ! treated as binary (100% inside or outside), or partially
1185 : ! (using the real grid area fractions), depending on the
1186 : ! HEMCO options.
1187 : ! ------------------------------------------------------------
1188 :
1189 : ! Default mask scaling is 1.0 (no mask applied)
1190 0 : MaskScale = 1.0_sp
1191 :
1192 : ! If there is a mask applied to this scale factor ...
1193 0 : IF ( isMaskDct ) THEN
1194 0 : CALL GetMaskVal ( MaskDct, I, J, MaskScale, MaskFractions, RC )
1195 0 : IF ( RC /= HCO_SUCCESS ) THEN
1196 : ERROR = 4
1197 : EXIT
1198 : ENDIF
1199 : ENDIF
1200 :
1201 : ! We can skip this grid box if mask is completely zero
1202 0 : IF ( MaskScale <= 0.0_sp ) CYCLE
1203 :
1204 : ! Get current time index for this container and at this location
1205 0 : tIDx = tIDx_GetIndx( HcoState, ScalDct%Dta, I, J )
1206 0 : IF ( tIDx < 1 ) THEN
1207 0 : WRITE(*,*) 'Cannot get time slice index at location ',I,J,&
1208 0 : ': ', TRIM(ScalDct%cName), tIDx
1209 0 : ERROR = 3
1210 0 : EXIT
1211 : ENDIF
1212 :
1213 : ! Check if this is a mask. If so, add mask values to the MASK
1214 : ! array. For now, we assume masks to be binary, i.e. 0 or 1.
1215 : ! We may want to change that in future to also support values
1216 : ! in between. This is especially important when regridding
1217 : ! high resolution masks onto coarser grids!
1218 : ! ------------------------------------------------------------
1219 0 : IF ( ScalDct%DctType == HCO_DCTTYPE_MASK ) THEN
1220 :
1221 : ! Get mask value
1222 0 : CALL GetMaskVal( ScalDct, I, J, TMPVAL, MaskFractions, RC )
1223 0 : IF ( RC /= HCO_SUCCESS ) THEN
1224 : ERROR = 4
1225 : EXIT
1226 : ENDIF
1227 :
1228 : ! Pass to output mask
1229 0 : MASK(I,J,:) = MASK(I,J,:) * TMPVAL
1230 :
1231 : ! testing only
1232 0 : IF ( HCO_IsVerb(HcoState%Config%Err,2) .AND. I==1 .AND. J==1 ) THEN
1233 0 : write(MSG,*) 'Mask field ', TRIM(ScalDct%cName), &
1234 0 : ' found and added to temporary mask.'
1235 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1236 : ENDIF
1237 :
1238 : ! Advance to next grid box
1239 : CYCLE
1240 : ENDIF! DctType=MASK
1241 :
1242 : ! ------------------------------------------------------------
1243 : ! For non-mask fields, apply scale factors to all levels
1244 : ! of the base field individually. If the scale factor
1245 : ! field has more than one vertical level, use the
1246 : ! vertical level closest to the corresponding vertical
1247 : ! level of the base emission field
1248 : ! ------------------------------------------------------------
1249 :
1250 : ! Get lower and upper vertical index
1251 : CALL GetVertIndx( HcoState, BaseDct, isLevDct1, &
1252 : LevDct1, LevDct1_Unit, isLevDct2, &
1253 : LevDct2, LevDct2_Unit, I, &
1254 0 : J, LowLL, UppLL, RC )
1255 0 : IF ( RC /= HCO_SUCCESS ) THEN
1256 : ERROR = 1 ! Will cause error
1257 : EXIT
1258 : ENDIF
1259 :
1260 : ! Loop over all vertical levels of the base field
1261 0 : DO L = LowLL,UppLL
1262 : ! If the vertical level exceeds the number of available
1263 : ! scale factor levels, use the highest available level.
1264 0 : IF ( L > ScalLL ) THEN
1265 0 : TmpLL = ScalLL
1266 : ! Otherwise use the same vertical level index.
1267 : ELSE
1268 0 : TmpLL = L
1269 : ENDIF
1270 :
1271 : ! Get scale factor for this grid box. Use same uniform
1272 : ! value if it's a scalar field
1273 0 : IF ( ScalDct%Dta%SpaceDim == 1 ) THEN
1274 0 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(1,1)
1275 0 : ELSEIF ( ScalDct%Dta%SpaceDim == 2 ) THEN
1276 0 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(I,J)
1277 : ELSE
1278 0 : TMPVAL = ScalDct%Dta%V3(tidx)%Val(I,J,TmpLL)
1279 : ENDIF
1280 :
1281 : ! Set missing value to one
1282 0 : IF ( TMPVAL == HCO_MISSVAL ) TMPVAL = 1.0_sp
1283 :
1284 : ! Eventually apply mask scaling
1285 0 : IF ( MaskScale /= 1.0_sp ) THEN
1286 0 : TMPVAL = TMPVAL * MaskScale
1287 : ENDIF
1288 :
1289 : ! For negative scale factor, proceed according to the
1290 : ! negative value setting specified in the configuration
1291 : ! file (NegFlag = 2: use this value):
1292 0 : IF ( TMPVAL < 0.0_sp .AND. HcoState%Options%NegFlag /= 2 ) THEN
1293 :
1294 : ! NegFlag = 1: ignore and show warning
1295 0 : IF ( HcoState%Options%NegFlag == 1 ) THEN
1296 : ERROR = -1 ! Will prompt warning
1297 : CYCLE
1298 :
1299 : ! Return w/ error otherwise
1300 : ELSE
1301 0 : WRITE(*,*) 'Negative scale factor at ',I,J,TmpLL,tidx,&
1302 0 : ': ', TRIM(ScalDct%cName), TMPVAL
1303 0 : ERROR = 1 ! Will cause error
1304 0 : EXIT
1305 : ENDIF
1306 : ENDIF
1307 :
1308 : ! -------------------------------------------------------
1309 : ! Apply scale factor in accordance to field operator
1310 : ! -------------------------------------------------------
1311 :
1312 : ! Oper 1: multiply
1313 0 : IF ( ScalDct%Oper == 1 ) THEN
1314 0 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL
1315 :
1316 : ! Oper -1: divide
1317 0 : ELSEIF ( ScalDct%Oper == -1 ) THEN
1318 : ! Ignore zeros to avoid NaN
1319 0 : IF ( TMPVAL /= 0.0_sp ) THEN
1320 0 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) / TMPVAL
1321 : ENDIF
1322 :
1323 : ! Oper 2: square
1324 0 : ELSEIF ( ScalDct%Oper == 2 ) THEN
1325 0 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL * TMPVAL
1326 :
1327 : ! Return w/ error otherwise (Oper 3 is only allowed for masks!)
1328 : ELSE
1329 0 : WRITE(*,*) 'Illegal operator for ', TRIM(ScalDct%cName), ScalDct%Oper
1330 0 : ERROR = 2 ! Will cause error
1331 0 : EXIT
1332 : ENDIF
1333 :
1334 : ENDDO !LL
1335 :
1336 : ! Verbose mode
1337 0 : if ( HCO_IsVerb(HcoState%Config%Err,3) .and. i == ix .and. j == iy ) then
1338 0 : write(MSG,*) 'Scale field ', TRIM(ScalDct%cName)
1339 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1340 0 : write(MSG,*) 'Time slice: ', tIdx
1341 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1342 0 : write(MSG,*) 'IX, IY: ', IX, IY
1343 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1344 0 : write(MSG,*) 'Scale factor (IX,IY,L1): ', TMPVAL
1345 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1346 0 : write(MSG,*) 'Mathematical operation : ', ScalDct%Oper
1347 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1348 : ! write(lun,*) 'Updt (IX,IY,L1): ', OUTARR_3D(IX,IY,1)
1349 : endif
1350 :
1351 : ENDDO !I
1352 : ENDDO !J
1353 : !$OMP END PARALLEL DO
1354 :
1355 : ! error check
1356 0 : IF ( ERROR > 0 ) THEN
1357 0 : IF ( ERROR == 1 ) THEN
1358 0 : MSG = 'Negative scale factor found (aborted): ' // TRIM(ScalDct%cName)
1359 0 : ELSEIF ( ERROR == 2 ) THEN
1360 0 : MSG = 'Illegal mathematical operator for scale factor: ' // TRIM(ScalDct%cName)
1361 0 : ELSEIF ( ERROR == 3 ) THEN
1362 0 : MSG = 'Encountered negative time index for scale factor: ' // TRIM(ScalDct%cName)
1363 : ELSEIF ( ERROR == 3 ) THEN
1364 : MSG = 'Mask error in ' // TRIM(ScalDct%cName)
1365 : ELSE
1366 0 : MSG = 'Error when applying scale factor: ' // TRIM(ScalDct%cName)
1367 : ENDIF
1368 0 : ScalDct => NULL()
1369 0 : CALL HCO_ERROR( MSG, RC )
1370 0 : RETURN
1371 : ENDIF
1372 :
1373 : ! eventually prompt warning for negative values
1374 0 : IF ( ERROR == -1 ) THEN
1375 0 : MSG = 'Negative scale factor found (ignored): ' // TRIM(ScalDct%cName)
1376 0 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC )
1377 : ENDIF
1378 :
1379 : ! Free pointer
1380 0 : MaskDct => NULL()
1381 :
1382 : ENDDO ! N
1383 : ENDIF ! N > 0
1384 :
1385 : ! Update optional variables
1386 0 : IF ( PRESENT(UseLL) ) THEN
1387 0 : UseLL = 1
1388 0 : IF ( nnLL > 0 ) UseLL = NINT(REAL(TotLL,kind=sp)/REAL(nnLL,kind=sp))
1389 : ENDIF
1390 :
1391 : ! Weight output emissions by mask
1392 0 : OUTARR_3D = OUTARR_3D * MASK
1393 :
1394 : ! Cleanup and leave w/ success
1395 0 : ScalDct => NULL()
1396 0 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
1397 :
1398 : END SUBROUTINE Get_Current_Emissions
1399 : !EOC
1400 : !------------------------------------------------------------------------------
1401 : ! Harmonized Emissions Component (HEMCO) !
1402 : !------------------------------------------------------------------------------
1403 : !BOP
1404 : !
1405 : ! !IROUTINE: Get_Current_Emissions_b (NOT USED!!)
1406 : !
1407 : ! !DESCRIPTION: Subroutine Get\_Current\_Emissions\_B calculates the current
1408 : ! emissions for the specified emission field and passes the result to
1409 : ! OUTARR\_3D.
1410 : !\\
1411 : !\\
1412 : ! This subroutine is only called by HCO\_CalcEmis and for fields with a valid
1413 : ! species ID, i.e. for base emission fields.
1414 : !
1415 : ! !!! WARNING: this routine is not actively developed any more and may lag
1416 : ! !!! behind Get\_Current\_Emissions
1417 : !\\
1418 : !\\
1419 : ! !INTERFACE:
1420 : !
1421 : SUBROUTINE Get_Current_Emissions_B( HcoState, BaseDct, &
1422 : nI, nJ, nL, OUTARR_3D, MASK, RC )
1423 : !
1424 : ! !USES:
1425 : !
1426 : USE HCO_STATE_MOD, ONLY : HCO_State
1427 : USE HCO_TIDX_MOD, ONLY : tIDx_GetIndx
1428 : USE HCO_FILEDATA_MOD, ONLY : FileData_ArrIsDefined
1429 : !
1430 : ! !INPUT PARAMETERS:
1431 : !
1432 : INTEGER, INTENT(IN) :: nI ! # of lons
1433 : INTEGER, INTENT(IN) :: nJ ! # of lats
1434 : INTEGER, INTENT(IN) :: nL ! # of levs
1435 : !
1436 : ! !INPUT/OUTPUT PARAMETERS:
1437 : !
1438 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
1439 : TYPE(DataCont), POINTER :: BaseDct ! base emission
1440 : ! container
1441 : REAL(hp), INTENT(INOUT) :: OUTARR_3D(nI,nJ,nL) ! output array
1442 : REAL(hp), INTENT(INOUT) :: MASK (nI,nJ,nL) ! mask array
1443 : INTEGER, INTENT(INOUT) :: RC
1444 : !
1445 : ! !REVISION HISTORY:
1446 : ! 25 Aug 2012 - C. Keller - Initial Version
1447 : ! See https://github.com/geoschem/hemco for complete history
1448 : !EOP
1449 : !------------------------------------------------------------------------------
1450 : !BOC
1451 : !
1452 : ! !LOCAL VARIABLES:
1453 : !
1454 : ! Pointers
1455 : TYPE(DataCont), POINTER :: ScalDct
1456 : TYPE(DataCont), POINTER :: MaskDct
1457 : REAL(sp) :: TMPVAL, MaskScale
1458 : INTEGER :: tIdx, IDX
1459 : INTEGER :: I, J, L, N
1460 : INTEGER :: LowLL, UppLL, ScalLL, TmpLL
1461 : INTEGER :: IJFILLED
1462 : INTEGER :: ERROR
1463 : CHARACTER(LEN=255) :: MSG, LOC
1464 : LOGICAL :: MaskFractions
1465 :
1466 : ! testing only
1467 : INTEGER :: IX, IY
1468 : LOGICAL :: verb
1469 :
1470 : !=================================================================
1471 : ! GET_CURRENT_EMISSIONS_B begins here
1472 : !=================================================================
1473 :
1474 : ! Initialize
1475 : ScalDct => NULL()
1476 : MaskDct => NULL()
1477 : LOC = 'GET_CURRENT_EMISSIONS_B (HCO_CALC_MOD.F90)'
1478 :
1479 : ! Enter
1480 : CALL HCO_ENTER(HcoState%Config%Err, LOC, RC )
1481 : IF(RC /= HCO_SUCCESS) RETURN
1482 :
1483 : ! testing only
1484 : verb = HCO_IsVerb(HcoState%Config%Err,1)
1485 : IX = 60 !40 !19 43 61
1486 : IY = 32 !36 !33 26 37
1487 :
1488 : ! Check if field data is defined
1489 : IF ( .NOT. FileData_ArrIsDefined(BaseDct%Dta) ) THEN
1490 : MSG = 'Array not defined: ' // TRIM(BaseDct%cName)
1491 : CALL HCO_ERROR( MSG, RC )
1492 : RETURN
1493 : ENDIF
1494 :
1495 : ! Testing only:
1496 : IF ( verb ) THEN
1497 : write(MSG,*) '--> GET EMISSIONS FOR ', TRIM(BaseDct%cName)
1498 : CALL HCO_MSG(HcoState%Config%Err,MSG)
1499 : ENDIF
1500 :
1501 : ! Initialize mask values
1502 : MASK(:,:,:) = 1.0_hp
1503 : MaskFractions = HcoState%Options%MaskFractions
1504 :
1505 : ! Initialize ERROR. Will be set to 1 if error occurs below
1506 : ERROR = 0
1507 :
1508 : ! Loop over all grid boxes
1509 : !$OMP PARALLEL DO &
1510 : !$OMP DEFAULT( SHARED ) &
1511 : !$OMP PRIVATE( I, J, LowLL, UppLL, tIdx, IJFILLED, L ) &
1512 : !$OMP PRIVATE( TMPVAL, N, IDX, ScalDct, ScalLL, tmpLL, MaskScale )
1513 : DO J = 1, nJ
1514 : DO I = 1, nI
1515 :
1516 : ! -------------------------------------------------------------
1517 : ! Set base emissions
1518 : ! -------------------------------------------------------------
1519 :
1520 : ! Get vertical extension of base emission array.
1521 : ! Unlike the output array OUTARR_3D, the data containers do not
1522 : ! necessarily extent over the entire troposphere but only cover
1523 : ! the effectively filled vertical levels. For most inventories,
1524 : ! this is only the first model level.
1525 : IF ( BaseDct%Dta%SpaceDim==3 ) THEN
1526 : LowLL = 1
1527 : UppLL = SIZE(BaseDct%Dta%V3(1)%Val,3)
1528 : ELSE
1529 : !LowLL = BaseDct%Dta%Lev2D
1530 : !UppLL = BaseDct%Dta%Lev2D
1531 : LowLL = 1
1532 : UppLL = 1
1533 : ENDIF
1534 :
1535 : ! Precalculate timeslice index. The data containers can
1536 : ! carry 2D/3D arrays for multiple time steps (i.e. for
1537 : ! every hour of the day), stored in a vector.
1538 : ! tIdxVec contains the vector index to be used at the current
1539 : ! datetime. This parameter may vary with longitude due to time
1540 : ! zone shifts!
1541 : tIDx = tIDx_GetIndx( HcoState, BaseDct%Dta, I, J )
1542 : IF ( tIDx < 0 ) THEN
1543 : write(MSG,*) 'Cannot get time slice index at location ',I,J,&
1544 : ': ', TRIM(BaseDct%cName)
1545 : ERROR = 3
1546 : EXIT
1547 : ENDIF
1548 :
1549 : ! # of levels w/ defined emissions
1550 : IJFILLED = 0
1551 :
1552 : ! Loop over all levels
1553 : DO L = LowLL, UppLL
1554 :
1555 : ! Get base value. Use uniform value if scalar field.
1556 : IF ( BaseDct%Dta%SpaceDim == 1 ) THEN
1557 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(1,1)
1558 : ELSEIF ( BaseDct%Dta%SpaceDim == 2 ) THEN
1559 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(I,J)
1560 : ELSE
1561 : TMPVAL = BaseDct%Dta%V3(tIDx)%Val(I,J,L)
1562 : ENDIF
1563 :
1564 : ! Check for missing value
1565 : IF ( TMPVAL == HCO_MISSVAL ) THEN
1566 : OUTARR_3D(I,J,L) = 0.0_hp
1567 : MASK(I,J,:) = 0.0_hp
1568 :
1569 : ! Pass base value to output array
1570 : ELSE
1571 : OUTARR_3D(I,J,L) = TMPVAL
1572 : ENDIF
1573 :
1574 : ! Update IJFILLED
1575 : IJFILLED = IJFILLED + 1
1576 :
1577 : ENDDO !L
1578 :
1579 : ! -------------------------------------------------------------
1580 : ! Apply scale factors
1581 : ! The container IDs of all scale factors associated with this base
1582 : ! container are stored in vector Scal_cID.
1583 : ! -------------------------------------------------------------
1584 :
1585 : ! Loop over maximum number of scale factors
1586 : IF ( BaseDct%nScalID > 0 ) THEN
1587 : DO N = 1, BaseDct%nScalID
1588 :
1589 : ! Get the scale factor container ID for the current slot
1590 : IDX = BaseDct%Scal_cID(N)
1591 :
1592 : ! Point to emission container with the given container ID
1593 : CALL Pnt2DataCont( HcoState, IDX, ScalDct, RC )
1594 : IF ( RC /= HCO_SUCCESS ) THEN
1595 : ERROR = 4
1596 : EXIT
1597 : ENDIF
1598 :
1599 : ! Scale field cannot be a base field
1600 : IF ( (ScalDct%DctType == HCO_DCTTYPE_BASE) ) THEN
1601 : ERROR = 4
1602 : EXIT
1603 : ENDIF
1604 :
1605 : ! Skip this scale factor if no data defined. This is possible
1606 : ! if scale factors are only defined for a given time range and
1607 : ! the simulation datetime is outside of this range.
1608 : IF ( .NOT. FileData_ArrIsDefined(ScalDct%Dta) ) THEN
1609 : MSG = 'Array not defined: ' // TRIM(ScalDct%cName)
1610 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC )
1611 : CYCLE
1612 : ENDIF
1613 :
1614 : ! Check if there is a mask field associated with this scale
1615 : ! factor. In this case, get a pointer to the corresponding
1616 : ! mask field and evaluate scale factors only inside the mask
1617 : ! region.
1618 : IF ( ASSOCIATED(ScalDct%Scal_cID) ) THEN
1619 : CALL Pnt2DataCont( HcoState, ScalDct%Scal_cID(1), MaskDct, RC )
1620 : IF ( RC /= HCO_SUCCESS ) THEN
1621 : ERROR = 5
1622 : EXIT
1623 : ENDIF
1624 :
1625 : ! Must be mask field
1626 : IF ( MaskDct%DctType /= HCO_DCTTYPE_MASK ) THEN
1627 : MSG = 'Invalid mask for scale factor: '//TRIM(ScalDct%cName)
1628 : MSG = TRIM(MSG) // '; mask: '//TRIM(MaskDct%cName)
1629 : CALL HCO_ERROR( MSG, RC )
1630 : ERROR = 5
1631 : EXIT
1632 : ENDIF
1633 :
1634 : ! Get mask value
1635 : CALL GetMaskVal( ScalDct, I, J, TMPVAL, MaskFractions, RC )
1636 : IF ( RC /= HCO_SUCCESS ) THEN
1637 : ERROR = 6
1638 : EXIT
1639 : ENDIF
1640 :
1641 : ENDIF
1642 :
1643 : ! Get vertical extension of this scale factor array.
1644 : IF( (ScalDct%Dta%SpaceDim<=2) ) THEN
1645 : ScalLL = 1
1646 : ELSE
1647 : ScalLL = SIZE(ScalDct%Dta%V3(1)%Val,3)
1648 : ENDIF
1649 :
1650 : ! Get current time index
1651 : tIDx = tIDx_GetIndx( HcoState, ScalDct%Dta, I, J )
1652 : IF ( tIDx < 0 ) THEN
1653 : write(MSG,*) 'Cannot get time slice index at location ',I,J,&
1654 : ': ', TRIM(ScalDct%cName)
1655 : ERROR = 3
1656 : EXIT
1657 : ENDIF
1658 :
1659 : ! ------------------------------------------------------------
1660 : ! Check if this is a mask. If so, add mask values to the MASK
1661 : ! array. For now, we assume masks to be binary, i.e. 0 or 1.
1662 : ! We may want to change that in future to also support values
1663 : ! in between. This is especially important when regridding
1664 : ! high resolution masks onto coarser grids!
1665 : ! ------------------------------------------------------------
1666 : IF ( ScalDct%DctType == HCO_DCTTYPE_MASK ) THEN
1667 :
1668 : ! Get mask value
1669 : CALL GetMaskVal( ScalDct, I, J, TMPVAL, MaskFractions, RC )
1670 : IF ( RC /= HCO_SUCCESS ) THEN
1671 : ERROR = 6
1672 : EXIT
1673 : ENDIF
1674 :
1675 : ! Pass to mask
1676 : MASK(I,J,:) = MASK(I,J,:) * TMPVAL
1677 :
1678 : ! testing only
1679 : if ( verb .and. i == ix .and. j == iy ) then
1680 : write(*,*) 'Mask field ', TRIM(ScalDct%cName), &
1681 : ' found and added to temporary mask.'
1682 : ENDIF
1683 :
1684 : ! Advance to next scale factor
1685 : CYCLE
1686 : ENDIF! DctType=MASK
1687 :
1688 : ! ------------------------------------------------------------
1689 : ! For non-mask fields, apply scale factors to all levels
1690 : ! of the base field individually. If the scale factor
1691 : ! field has more than one vertical level, use the
1692 : ! vertical level closest to the corresponding vertical
1693 : ! level in the base emission field
1694 : ! ------------------------------------------------------------
1695 :
1696 : ! Loop over all vertical levels of the base field
1697 : DO L = LowLL,UppLL
1698 : ! If the vertical level exceeds the number of available
1699 : ! scale factor levels, use the highest available level.
1700 : IF ( L > ScalLL ) THEN
1701 : TmpLL = ScalLL
1702 : ! Otherwise use the same vertical level index.
1703 : ELSE
1704 : TmpLL = L
1705 : ENDIF
1706 :
1707 : ! Get scale factor for this grid box. Use same uniform
1708 : ! value if it's a scalar field
1709 : IF ( ScalDct%Dta%SpaceDim == 1 ) THEN
1710 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(1,1)
1711 : ELSEIF ( ScalDct%Dta%SpaceDim == 2 ) THEN
1712 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(I,J)
1713 : ELSE
1714 : TMPVAL = ScalDct%Dta%V3(tidx)%Val(I,J,TmpLL)
1715 : ENDIF
1716 :
1717 : ! Check for missing value
1718 : IF ( TMPVAL == HCO_MISSVAL ) TMPVAL = 1.0_sp
1719 :
1720 : ! For negative scale factor, proceed according to the
1721 : ! negative value setting specified in the configuration
1722 : ! file (NegFlag = 2: use this value):
1723 : IF ( TMPVAL < 0.0_sp .AND. HcoState%Options%NegFlag /= 2 ) THEN
1724 :
1725 : ! NegFlag = 1: ignore and show warning
1726 : IF ( HcoState%Options%NegFlag == 1 ) THEN
1727 : ERROR = -1 ! Will prompt warning
1728 : CYCLE
1729 :
1730 : ! Return w/ error otherwise
1731 : ELSE
1732 : WRITE(*,*) 'Negative scale factor at ',I,J,TmpLL,tidx,&
1733 : ': ', TRIM(ScalDct%cName), TMPVAL
1734 : ERROR = 1 ! Will cause error
1735 : EXIT
1736 : ENDIF
1737 : ENDIF
1738 :
1739 : ! -------------------------------------------------------
1740 : ! Apply scale factor according to field operator
1741 : ! -------------------------------------------------------
1742 :
1743 : ! Oper 1: multiply
1744 : IF ( ScalDct%Oper == 1 ) THEN
1745 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL
1746 :
1747 : ! Oper -1: divide
1748 : ELSEIF ( ScalDct%Oper == -1 ) THEN
1749 : ! Ignore zeros to avoid NaN
1750 : IF ( TMPVAL /= 0.0_sp ) THEN
1751 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) / TMPVAL
1752 : ENDIF
1753 :
1754 : ! Oper 2: square
1755 : ELSEIF ( ScalDct%Oper == 2 ) THEN
1756 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL * TMPVAL
1757 :
1758 : ! Return w/ error otherwise (Oper 3 only allowed for masks!)
1759 : ELSE
1760 : MSG = 'Illegal data operator: ' // TRIM(ScalDct%cName)
1761 : CALL HCO_ERROR( MSG, RC )
1762 : ERROR = 2
1763 : EXIT
1764 : ENDIF
1765 : ENDDO !LL
1766 : ENDDO ! N
1767 : ENDIF ! N > 0
1768 :
1769 : ! ----------------------------
1770 : ! Masks
1771 : ! ----------------------------
1772 :
1773 : ! Apply the mask. Make sure that emissions become negative
1774 : ! outside the mask region. This is to make sure that these
1775 : ! grid boxes will be ignored when calculating the final
1776 : ! emissions.
1777 : WHERE ( MASK(I,J,:) == 0 )
1778 : OUTARR_3D(I,J,:) = 0.0_hp
1779 : ENDWHERE
1780 :
1781 : ENDDO !I
1782 : ENDDO !J
1783 : !$OMP END PARALLEL DO
1784 :
1785 : ! Error check
1786 : IF ( ERROR > 0 ) THEN
1787 : IF ( ERROR == 1 ) THEN
1788 : MSG = 'Negative scale factor found (aborted): ' // TRIM(ScalDct%cName)
1789 : ELSEIF ( ERROR == 2 ) THEN
1790 : MSG = 'Illegal mathematical operator for scale factor: ' // TRIM(ScalDct%cName)
1791 : ELSEIF ( ERROR == 3 ) THEN
1792 : MSG = 'Encountered negative time index for scale factor: ' // TRIM(ScalDct%cName)
1793 : ELSE
1794 : MSG = 'Error when applying scale factor: ' // TRIM(ScalDct%cName)
1795 : ENDIF
1796 : CALL HCO_ERROR( MSG, RC )
1797 : ScalDct => NULL()
1798 : RETURN
1799 : ENDIF
1800 :
1801 : ! eventually prompt warning for negative values
1802 : IF ( ERROR == -1 ) THEN
1803 : MSG = 'Negative scale factor found (ignored): ' // TRIM(ScalDct%cName)
1804 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC )
1805 : ENDIF
1806 :
1807 : ! Leave
1808 : ScalDct => NULL()
1809 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
1810 :
1811 : END SUBROUTINE Get_Current_Emissions_B
1812 : !EOC
1813 : !------------------------------------------------------------------------------
1814 : ! Harmonized Emissions Component (HEMCO) !
1815 : !------------------------------------------------------------------------------
1816 : !BOP
1817 : !
1818 : ! !IROUTINE: HCO_EvalFld_3D
1819 : !
1820 : ! !DESCRIPTION: Subroutine HCO\_EvalFld\_3D returns the 3D data field belonging
1821 : ! to the emissions list data container with field name 'cName'. The returned
1822 : ! data field is the completely evaluated field, e.g. the base field multiplied
1823 : ! by all scale factors and with all masking being applied (as specified in the
1824 : ! HEMCO configuration file). This distinguished this routine from HCO\_GetPtr
1825 : ! in hco\_emislist\_mod.F90, which returns a reference to the unevaluated data
1826 : ! field.
1827 : !\\
1828 : !\\
1829 : ! !INTERFACE:
1830 : !
1831 0 : SUBROUTINE HCO_EvalFld_3D( HcoState, cName, Arr3D, RC, FOUND )
1832 : !
1833 : ! !USES:
1834 : !
1835 : USE HCO_STATE_MOD, ONLY : HCO_State
1836 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
1837 : !
1838 : ! !INPUT PARAMETERS:
1839 : !
1840 : CHARACTER(LEN=*), INTENT(IN ) :: cName
1841 : !
1842 : ! !INPUT/OUTPUT PARAMETERS:
1843 : !
1844 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
1845 : REAL(hp), INTENT(INOUT) :: Arr3D(:,:,:) ! 3D array
1846 : INTEGER, INTENT(INOUT) :: RC ! Return code
1847 : !
1848 : ! !OUTPUT PARAMETERS:
1849 : !
1850 : LOGICAL, INTENT( OUT), OPTIONAL :: FOUND
1851 : !
1852 : ! !REVISION HISTORY:
1853 : ! 11 May 2015 - C. Keller - Initial Version
1854 : ! See https://github.com/geoschem/hemco for complete history
1855 : !EOP
1856 : !------------------------------------------------------------------------------
1857 : !BOC
1858 : !
1859 : ! !LOCAL VARIABLES:
1860 : !
1861 : ! Scalars
1862 : LOGICAL :: FND
1863 : INTEGER :: AS, nI, nJ, nL, FLAG
1864 :
1865 : ! Arrays
1866 0 : REAL(hp), ALLOCATABLE :: Mask(:,:,:)
1867 :
1868 : ! Working pointers: list and data container
1869 : TYPE(ListCont), POINTER :: Lct
1870 :
1871 : ! For error handling & verbose mode
1872 : CHARACTER(LEN=255) :: MSG
1873 : CHARACTER(LEN=255) :: LOC = "HCO_EvalFld_3d (HCO_calc_mod.F90)"
1874 :
1875 : !=================================================================
1876 : ! HCO_EvalFld_3D begins here!
1877 : !=================================================================
1878 :
1879 : ! Init
1880 0 : RC = HCO_SUCCESS
1881 0 : Lct => NULL()
1882 0 : IF ( PRESENT(FOUND) ) FOUND = .FALSE.
1883 :
1884 : ! Search for base container
1885 0 : CALL ListCont_Find ( HcoState%EmisList, TRIM(cName), FND, Lct )
1886 0 : IF ( PRESENT(FOUND) ) FOUND = FND
1887 :
1888 : ! If not found, return here
1889 0 : IF ( .NOT. FND ) THEN
1890 0 : IF ( PRESENT(FOUND) ) THEN
1891 0 : RETURN
1892 : ELSE
1893 0 : MSG = 'Cannot find in EmisList: ' // TRIM(cName)
1894 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
1895 0 : RETURN
1896 : ENDIF
1897 : ENDIF
1898 :
1899 : ! Init
1900 0 : Arr3D = 0.0_hp
1901 :
1902 : ! Define output dimensions
1903 0 : nI = SIZE(Arr3D,1)
1904 0 : nJ = SIZE(Arr3D,2)
1905 0 : nL = SIZE(Arr3D,3)
1906 :
1907 : ! Sanity check: horizontal grid dimensions are expected to be on HEMCO grid
1908 0 : IF ( nI /= HcoState%NX .OR. nJ /= HcoState%nY ) THEN
1909 0 : WRITE(MSG,*) "Horizontal dimension error: ", TRIM(cName), nI, nJ
1910 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
1911 0 : RETURN
1912 : ENDIF
1913 :
1914 : ! Make sure mask array is defined
1915 0 : ALLOCATE(MASK(nI,nJ,nL),STAT=AS)
1916 0 : IF ( AS /= 0 ) THEN
1917 0 : CALL HCO_ERROR( 'Cannot allocate MASK', RC, THISLOC=LOC )
1918 0 : RETURN
1919 : ENDIF
1920 0 : mask = 0.0_hp
1921 :
1922 : ! Calculate emissions for base container
1923 : CALL GET_CURRENT_EMISSIONS( HcoState, Lct%Dct, nI, nJ, &
1924 0 : nL, Arr3D, Mask, RC )
1925 0 : IF ( RC /= HCO_SUCCESS ) THEN
1926 0 : CALL HCO_ERROR( 'ERROR 14', RC, THISLOC=LOC )
1927 0 : RETURN
1928 : ENDIF
1929 :
1930 : ! All done
1931 0 : IF (ALLOCATED(MASK) ) DEALLOCATE(MASK)
1932 0 : Lct => NULL()
1933 :
1934 0 : END SUBROUTINE HCO_EvalFld_3D
1935 : !EOC
1936 : !------------------------------------------------------------------------------
1937 : ! Harmonized Emissions Component (HEMCO) !
1938 : !------------------------------------------------------------------------------
1939 : !BOP
1940 : !
1941 : ! !IROUTINE: HCO_EvalFld_2D
1942 : !
1943 : ! !DESCRIPTION: Subroutine HCO\_EvalFld\_2D returns the 2D data field belonging
1944 : ! to the emissions list data container with field name 'cName'. The returned
1945 : ! data field is the completely evaluated field, e.g. the base field multiplied
1946 : ! by all scale factors and with all masking being applied (as specified in the
1947 : ! HEMCO configuration file). This distinguished this routine from HCO\_GetPtr
1948 : ! in hco\_emislist\_mod.F90, which returns a reference to the unevaluated data
1949 : ! field.
1950 : !\\
1951 : !\\
1952 : !\\
1953 : ! !INTERFACE:
1954 : !
1955 0 : SUBROUTINE HCO_EvalFld_2D( HcoState, cName, Arr2D, RC, FOUND )
1956 : !
1957 : ! !USES:
1958 : !
1959 : USE HCO_STATE_MOD, ONLY : HCO_State
1960 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
1961 : !
1962 : ! !INPUT PARAMETERS:
1963 : !
1964 : CHARACTER(LEN=*), INTENT(IN ) :: cName
1965 : !
1966 : ! !INPUT/OUTPUT PARAMETERS:
1967 : !
1968 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
1969 : REAL(hp), INTENT(INOUT) :: Arr2D(:,:) ! 2D array
1970 : INTEGER, INTENT(INOUT) :: RC ! Return code
1971 : !
1972 : ! !OUTPUT PARAMETERS:
1973 : !
1974 : LOGICAL, INTENT( OUT), OPTIONAL :: FOUND
1975 : !
1976 : ! !REVISION HISTORY:
1977 : ! 11 May 2015 - C. Keller - Initial Version
1978 : ! See https://github.com/geoschem/hemco for complete history
1979 : !EOP
1980 : !------------------------------------------------------------------------------
1981 : !BOC
1982 : !
1983 : ! !LOCAL VARIABLES:
1984 : !
1985 : ! Scalars
1986 : LOGICAL :: FND
1987 : INTEGER :: AS, nI, nJ, nL, UseLL, FLAG
1988 :
1989 : ! Arrays
1990 0 : REAL(hp), ALLOCATABLE :: Mask (:,:,:)
1991 0 : REAL(hp), ALLOCATABLE :: Arr3D(:,:,:)
1992 :
1993 : ! Working pointers: list and data container
1994 : TYPE(ListCont), POINTER :: Lct
1995 :
1996 : ! For error handling & verbose mode
1997 : CHARACTER(LEN=255) :: MSG
1998 : CHARACTER(LEN=255) :: LOC = "HCO_EvalFld_2d (HCO_calc_mod.F90)"
1999 :
2000 : !=================================================================
2001 : ! HCO_EvalFld_2D begins here!
2002 : !=================================================================
2003 :
2004 : ! Init
2005 0 : RC = HCO_SUCCESS
2006 0 : Lct => NULL()
2007 0 : IF ( PRESENT(FOUND) ) FOUND = .FALSE.
2008 :
2009 : ! Search for base container
2010 0 : CALL ListCont_Find ( HcoState%EmisList, TRIM(cName), FND, Lct )
2011 0 : IF ( PRESENT(FOUND) ) FOUND = FND
2012 :
2013 : ! If not found, return here
2014 0 : IF ( .NOT. FND ) THEN
2015 0 : IF ( PRESENT(FOUND) ) THEN
2016 0 : RETURN
2017 : ELSE
2018 0 : MSG = 'Cannot find in EmisList: ' // TRIM(cName)
2019 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
2020 0 : RETURN
2021 : ENDIF
2022 : ENDIF
2023 :
2024 : ! Init Arr2D
2025 0 : Arr2D = 0.0_hp
2026 :
2027 : ! Define output dimensions
2028 0 : nI = SIZE(Arr2D,1)
2029 0 : nJ = SIZE(Arr2D,2)
2030 0 : nL = 1
2031 :
2032 : ! Sanity check: horizontal grid dimensions are expected to be on HEMCO grid
2033 0 : IF ( nI /= HcoState%NX .OR. nJ /= HcoState%nY ) THEN
2034 0 : WRITE(MSG,*) "Horizontal dimension error: ", TRIM(cName), nI, nJ
2035 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
2036 0 : RETURN
2037 : ENDIF
2038 :
2039 : ! Make sure mask array is defined
2040 0 : ALLOCATE(MASK(nI,nJ,nL),Arr3D(nI,nJ,nL),STAT=AS)
2041 0 : IF ( AS /= 0 ) THEN
2042 0 : CALL HCO_ERROR( 'Cannot allocate MASK', RC, THISLOC=LOC )
2043 0 : RETURN
2044 : ENDIF
2045 0 : Arr3D = 0.0_hp
2046 0 : Mask = 0.0_hp
2047 :
2048 : ! Calculate emissions for base container
2049 : CALL GET_CURRENT_EMISSIONS( HcoState, Lct%Dct, nI, nJ, &
2050 0 : nL, Arr3D, Mask, RC, UseLL=UseLL )
2051 0 : IF ( RC /= HCO_SUCCESS ) THEN
2052 0 : CALL HCO_ERROR( 'ERROR 15', RC, THISLOC=LOC )
2053 0 : RETURN
2054 : ENDIF
2055 :
2056 : ! Place 3D array into 2D array. UseLL returns the vertical level into which
2057 : ! emissions have been added within GET_CURRENT_EMISSIONS. This should be
2058 : ! level 1 for most cases but it can be another level if specified so.
2059 : ! Return a warning if level is not 1 (ckeller, 11/1/16).
2060 0 : UseLL = MIN( MAX(useLL,1), SIZE(Arr3D,3) )
2061 0 : IF ( UseLL /= 1 ) THEN
2062 0 : WRITE(MSG,*) "2D data was emitted above surface - this information might be lost: " , TRIM(cName), UseLL
2063 0 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC, THISLOC=LOC, WARNLEV=2 )
2064 : ENDIF
2065 :
2066 : ! Pass 3D data to 2D array
2067 0 : Arr2D = Arr3D(:,:,UseLL)
2068 :
2069 : ! All done
2070 0 : IF (ALLOCATED(MASK ) ) DEALLOCATE(MASK )
2071 0 : IF (ALLOCATED(Arr3D) ) DEALLOCATE(Arr3D)
2072 0 : Lct => NULL()
2073 :
2074 0 : END SUBROUTINE HCO_EvalFld_2D
2075 : !EOC
2076 : !------------------------------------------------------------------------------
2077 : ! Harmonized Emissions Component (HEMCO) !
2078 : !------------------------------------------------------------------------------
2079 : !BOP
2080 : !
2081 : ! !IROUTINE: GetMaskVal
2082 : !
2083 : ! !DESCRIPTION: Subroutine GetMaskVal is a helper routine to get the mask
2084 : ! value at a given location.
2085 : !\\
2086 : !\\
2087 : ! !INTERFACE:
2088 : !
2089 0 : SUBROUTINE GetMaskVal ( Dct, I, J, MaskVal, Fractions, RC )
2090 : !
2091 : ! !USES:
2092 : !
2093 : !
2094 : ! !INPUT PARAMETERS:
2095 : !
2096 : INTEGER, INTENT(IN ) :: I ! # of lons
2097 : INTEGER, INTENT(IN ) :: J ! # of lats
2098 : LOGICAL, INTENT(IN ) :: Fractions ! Use fractions?
2099 : !
2100 : ! !INPUT/OUTPUT PARAMETERS:
2101 : !
2102 : TYPE(DataCont), POINTER :: Dct ! Mask container
2103 : REAL(sp), INTENT(INOUT) :: MaskVal
2104 : INTEGER, INTENT(INOUT) :: RC
2105 : !
2106 : ! !REVISION HISTORY:
2107 : ! 09 Apr 2015 - C. Keller - Initial Version
2108 : ! See https://github.com/geoschem/hemco for complete history
2109 : !EOP
2110 : !------------------------------------------------------------------------------
2111 : !BOC
2112 : !
2113 : ! !LOCAL VARIABLES:
2114 : !
2115 :
2116 : !=================================================================
2117 : ! GetMaskVal begins here
2118 : !=================================================================
2119 :
2120 : ! Mask value over this grid box
2121 0 : MaskVal = Dct%Dta%V2(1)%Val(I,J)
2122 :
2123 : ! Negative mask values are treated as zero (exclude).
2124 0 : IF ( (MaskVal <= 0.0_sp) .OR. (MaskVal == HCO_MISSVAL) ) THEN
2125 0 : MaskVal = 0.0_sp
2126 0 : ELSEIF ( MaskVal > 1.0_sp ) THEN
2127 0 : MaskVal = 1.0_sp
2128 : ENDIF
2129 :
2130 : ! For operator set to 3, mirror value
2131 : ! MaskVal=1 becomes 0 and MaskVal=0/missing becomes 1
2132 0 : IF ( Dct%Oper == 3 ) THEN
2133 0 : IF ( (MaskVal == 0.0_sp) .OR. (MaskVal == HCO_MISSVAL) ) THEN
2134 0 : MaskVal = 1.0_sp
2135 0 : ELSEIF ( MaskVal == 1.0_sp ) THEN
2136 0 : MaskVal = 1.0_sp - MaskVal
2137 : ENDIF
2138 : ENDIF
2139 :
2140 : ! Treat as binary?
2141 0 : IF ( .NOT. Fractions ) THEN
2142 0 : IF ( MaskVal < MASK_THRESHOLD ) THEN
2143 0 : MaskVal = 0.0_sp
2144 : ELSE
2145 0 : MaskVal = 1.0_sp
2146 : ENDIF
2147 : ENDIF
2148 :
2149 : ! Return w/ success
2150 0 : RC = HCO_SUCCESS
2151 :
2152 0 : END SUBROUTINE GetMaskVal
2153 : !EOC
2154 : !------------------------------------------------------------------------------
2155 : ! Harmonized Emissions Component (HEMCO) !
2156 : !------------------------------------------------------------------------------
2157 : !BOP
2158 : !
2159 : ! !IROUTINE: HCO_MaskFld
2160 : !
2161 : ! !DESCRIPTION: Subroutine HCO\_MaskFld is a helper routine to get the mask
2162 : ! field with the given name. The returned mask field is fully evaluated,
2163 : ! e.g. the data operation flag associated with this mask field is already
2164 : ! taken into account. For instance, if the data operator of a mask field is
2165 : ! set to 3, the returned array contains already the mirrored mask values.
2166 : !\\
2167 : !\\
2168 : ! !INTERFACE:
2169 : !
2170 0 : SUBROUTINE HCO_MaskFld ( HcoState, MaskName, Mask, RC, FOUND )
2171 : !
2172 : ! !USES:
2173 : !
2174 : USE HCO_STATE_MOD, ONLY : HCO_State
2175 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
2176 : !
2177 : ! !INPUT PARAMETERS:
2178 : !
2179 : TYPE(HCO_STATE), POINTER :: HcoState
2180 : CHARACTER(LEN=*),INTENT(IN ) :: MaskName
2181 : !
2182 : ! !INPUT/OUTPUT PARAMETERS:
2183 : !
2184 : REAL(sp), INTENT(INOUT) :: Mask(:,:)
2185 : INTEGER, INTENT(INOUT) :: RC
2186 : !
2187 : ! !OUTPUT PARAMETERS:
2188 : !
2189 : LOGICAL, INTENT( OUT), OPTIONAL :: FOUND
2190 : !
2191 : ! !REVISION HISTORY:
2192 : ! 11 Jun 2015 - C. Keller - Initial Version
2193 : ! See https://github.com/geoschem/hemco for complete history
2194 : !EOP
2195 : !------------------------------------------------------------------------------
2196 : !BOC
2197 : !
2198 : ! !LOCAL VARIABLES:
2199 : !
2200 : INTEGER :: I, J, FLAG
2201 :
2202 : LOGICAL :: FND, ERR
2203 : LOGICAL :: Fractions
2204 :
2205 : TYPE(ListCont), POINTER :: MaskLct
2206 :
2207 : CHARACTER(LEN=255) :: MSG
2208 : CHARACTER(LEN=255) :: LOC = 'HCO_MaskFld (hco_calc_mod.F90)'
2209 :
2210 : !=================================================================
2211 : ! HCO_MaskFld begins here
2212 : !=================================================================
2213 :
2214 : ! Nullify
2215 0 : MaskLct => NULL()
2216 :
2217 : ! Init: default is mask value of 1
2218 0 : MASK = 1.0_sp
2219 0 : ERR = .FALSE.
2220 0 : FND = .FALSE.
2221 :
2222 : ! Search for mask field within EmisList
2223 0 : CALL ListCont_Find ( HcoState%EmisList, TRIM(MaskName), FND, MaskLct )
2224 :
2225 0 : IF ( .NOT. FND .AND. .NOT. PRESENT(FOUND) ) THEN
2226 0 : MSG = 'Cannot find mask field ' // TRIM(MaskName)
2227 0 : CALL HCO_MSG(HcoState%Config%Err,MSG,SEP1='!')
2228 : MSG = 'Make sure this field is listed in the mask section ' // &
2229 : 'of the HEMCO configuration file. You may also need to ' // &
2230 0 : 'set the optional attribute `ReadAlways` to `yes`, e.g.'
2231 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
2232 0 : MSG = '5000 TESTMASK -140/10/-40/90 - - - xy 1 1 -140/10/-40/90 yes'
2233 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
2234 : CALL HCO_ERROR ( &
2235 0 : 'Error reading mask '//TRIM(MaskName), RC, THISLOC=LOC )
2236 0 : RETURN
2237 : ENDIF
2238 0 : IF ( PRESENT(FOUND) ) FOUND = FND
2239 :
2240 : ! Do only if found
2241 0 : IF ( FND ) THEN
2242 :
2243 : ! Use mask fractions?
2244 0 : Fractions = HcoState%Options%MaskFractions
2245 :
2246 : ! Make sure mask array has correct dimensions
2247 0 : IF ( SIZE(MASK,1) /= HcoState%NX .OR. SIZE(MASK,2) /= HcoState%NY ) THEN
2248 0 : WRITE(MSG,*) 'Input mask array has wrong dimensions. Must be ', &
2249 0 : HcoState%NX, HcoState%NY, ' but found ', SIZE(MASK,1), SIZE(MASK,2)
2250 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
2251 0 : RETURN
2252 : ENDIF
2253 :
2254 : ! Do for every grid box
2255 : !$OMP PARALLEL DO &
2256 : !$OMP DEFAULT( SHARED ) &
2257 : !$OMP PRIVATE( I, J )
2258 0 : DO J = 1, HcoState%NY
2259 0 : DO I = 1, HcoState%NX
2260 0 : CALL GetMaskVal( MaskLct%Dct, I, J, Mask(I,J), Fractions, RC )
2261 0 : IF ( RC /= HCO_SUCCESS ) THEN
2262 : ERR = .TRUE.
2263 : EXIT
2264 : ENDIF
2265 : ENDDO
2266 : ENDDO
2267 : !$OMP END PARALLEL DO
2268 :
2269 : ! Error check
2270 0 : IF ( ERR ) THEN
2271 0 : MSG = 'Error in GetMaskVal'
2272 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
2273 0 : RETURN
2274 : ENDIF
2275 :
2276 : ENDIF
2277 :
2278 : ! Free pointer
2279 0 : MaskLct => NULL()
2280 :
2281 : ! Return w/ success
2282 0 : RC = HCO_SUCCESS
2283 :
2284 : END SUBROUTINE HCO_MaskFld
2285 : !EOC
2286 : !------------------------------------------------------------------------------
2287 : ! Harmonized Emissions Component (HEMCO) !
2288 : !------------------------------------------------------------------------------
2289 : !BOP
2290 : !
2291 : ! !IROUTINE: GetVertIndx
2292 : !
2293 : ! !DESCRIPTION: Subroutine GetVertIndx is a helper routine to get the vertical
2294 : ! index range of the given data field.
2295 : !\\
2296 : !\\
2297 : ! !INTERFACE:
2298 : !
2299 0 : SUBROUTINE GetVertIndx( HcoState, Dct, isLevDct1, &
2300 : LevDct1, LevDct1_Unit, isLevDct2, &
2301 : LevDct2, LevDct2_Unit, I, &
2302 : J, LowLL, UppLL, RC )
2303 : !
2304 : ! !USES:
2305 : !
2306 : USE HCO_State_Mod, ONLY : HCO_State
2307 : !
2308 : ! !INPUT PARAMETERS:
2309 : !
2310 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2311 : LOGICAL, INTENT(IN) :: isLevDct1 ! Is LevDct1 not null?
2312 : TYPE(DataCont), POINTER :: LevDct1 ! Level index 1 container
2313 : INTEGER, INTENT(IN) :: LevDct1_Unit ! LevDct1 unit code
2314 : LOGICAL, INTENT(IN) :: isLevDct2 ! Is LevDct2 not null?
2315 : TYPE(DataCont), POINTER :: LevDct2 ! Level index 2 container
2316 : INTEGER, INTENT(IN) :: LevDct2_Unit ! LevDct2 unit code
2317 : INTEGER, INTENT(IN) :: I ! lon index
2318 : INTEGER, INTENT(IN) :: J ! lat index
2319 : !
2320 : ! !INPUT/OUTPUT PARAMETERS:
2321 : !
2322 : TYPE(DataCont), POINTER :: Dct ! Mask container
2323 : INTEGER, INTENT(INOUT) :: LowLL ! lower level index
2324 : INTEGER, INTENT(INOUT) :: UppLL ! upper level index
2325 : INTEGER, INTENT(INOUT) :: RC
2326 : !
2327 : ! !REVISION HISTORY:
2328 : ! 06 May 2016 - C. Keller - Initial Version
2329 : ! See https://github.com/geoschem/hemco for complete history
2330 : !EOP
2331 : !------------------------------------------------------------------------------
2332 : !BOC
2333 : !
2334 : ! !LOCAL VARIABLES:
2335 : !
2336 : INTEGER :: EmisLUnit
2337 : REAL(hp) :: EmisL
2338 : CHARACTER(LEN=255) :: LOC
2339 :
2340 : !=======================================================================
2341 : ! GetVertIndx begins here
2342 : !=======================================================================
2343 0 : LOC = 'GetVertIndx (HCO_CALC_MOD.F90)'
2344 :
2345 : !-----------------------------------------------------------------------
2346 : ! Get vertical extension of base emission array.
2347 : !
2348 : ! Unlike the output array OUTARR_3D, the data containers do not
2349 : ! necessarily extent over the entire troposphere but only cover
2350 : ! the effectively filled vertical levels. For most inventories,
2351 : ! this is only the first model level.
2352 : !-----------------------------------------------------------------------
2353 0 : IF ( Dct%Dta%SpaceDim==3 ) THEN
2354 0 : LowLL = 1
2355 0 : UppLL = SIZE(Dct%Dta%V3(1)%Val,3)
2356 0 : RC = HCO_SUCCESS
2357 0 : RETURN
2358 : ENDIF
2359 :
2360 : !-----------------------------------------------------------------------
2361 : ! For 2D field, check if it shall be spread out over multiple
2362 : ! levels. Possible to go from PBL to max. specified level.
2363 : !-----------------------------------------------------------------------
2364 :
2365 : ! Lower level
2366 : ! --> Check if scale factor is used to determine lower and/or
2367 : ! upper level
2368 0 : IF ( isLevDct1 ) THEN
2369 0 : EmisL = GetEmisL( HcoState, LevDct1, I, J )
2370 0 : IF ( EmisL < 0.0_hp ) THEN
2371 0 : RC = HCO_FAIL
2372 0 : RETURN
2373 : ENDIF
2374 0 : EmisLUnit = LevDct1_Unit
2375 : ELSE
2376 0 : EmisL = Dct%Dta%EmisL1
2377 0 : EmisLUnit = Dct%Dta%EmisL1Unit
2378 : ENDIF
2379 0 : CALL GetIdx( HcoState, I, J, EmisL, EmisLUnit, LowLL, RC )
2380 0 : IF ( RC /= HCO_SUCCESS ) THEN
2381 0 : CALL HCO_ERROR( 'ERROR 16', RC, THISLOC=LOC )
2382 0 : RETURN
2383 : ENDIF
2384 :
2385 : ! Upper level
2386 0 : IF ( isLevDct2 ) THEN
2387 0 : EmisL = GetEmisL( HcoState, LevDct2, I, J )
2388 0 : IF ( EmisL < 0.0_hp ) THEN
2389 0 : RC = HCO_FAIL
2390 0 : RETURN
2391 : ENDIF
2392 0 : EmisLUnit = LevDct2_Unit
2393 : ELSE
2394 0 : EmisL = Dct%Dta%EmisL2
2395 0 : EmisLUnit = Dct%Dta%EmisL2Unit
2396 : ENDIF
2397 0 : CALL GetIdx( HcoState, I, J, EmisL, EmisLUnit, UppLL, RC )
2398 0 : IF ( RC /= HCO_SUCCESS ) THEN
2399 0 : CALL HCO_ERROR( 'ERROR 17', RC, THISLOC=LOC )
2400 0 : RETURN
2401 : ENDIF
2402 :
2403 : ! Upper level must not be lower than lower level
2404 0 : UppLL = MAX(LowLL, UppLL)
2405 :
2406 : ! Return w/ success
2407 0 : RC = HCO_SUCCESS
2408 :
2409 : END SUBROUTINE GetVertIndx
2410 : !EOC
2411 : !------------------------------------------------------------------------------
2412 : ! Harmonized Emissions Component (HEMCO) !
2413 : !------------------------------------------------------------------------------
2414 : !BOP
2415 : !
2416 : ! !FUNCTION: GetEmisL
2417 : !
2418 : ! !DESCRIPTION: Returns the emission level read from a scale factor.
2419 : !\\
2420 : !\\
2421 : ! !INTERFACE:
2422 : !
2423 0 : FUNCTION GetEmisL( HcoState, LevDct, I, J ) RESULT ( EmisL )
2424 : !
2425 : ! !USES:
2426 : !
2427 : USE HCO_TYPES_MOD
2428 : USE HCO_STATE_MOD, ONLY : HCO_State
2429 : USE HCO_tIdx_MOD, ONLY : tIDx_GetIndx
2430 : !
2431 : ! !INPUT PARAMETERS:
2432 : !
2433 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2434 : TYPE(DataCont), POINTER :: LevDct ! Level index 1 container
2435 : INTEGER, INTENT(IN ) :: I, J ! horizontal index
2436 : !
2437 : ! !RETURN VALUE:
2438 : !
2439 : REAL(hp) :: EmisL
2440 : !
2441 : ! !REVISION HISTORY:
2442 : ! 26 Jan 2018 - C. Keller - Initial version
2443 : ! See https://github.com/geoschem/hemco for complete history
2444 : !EOP
2445 : !------------------------------------------------------------------------------
2446 : !BOC
2447 : !
2448 : ! !LOCAL VARIABLES:
2449 : !
2450 : INTEGER :: levtidx
2451 :
2452 : !=================================================================
2453 : ! GetEmisL begins here
2454 : !=================================================================
2455 0 : levtidx = tIDx_GetIndx( HcoState, LevDct%Dta, I, J )
2456 0 : IF ( levtidx <= 0 ) THEN
2457 : WRITE(*,*)' Cannot get time slice for field '//&
2458 0 : TRIM(LevDct%cName)//': GetEmisL (hco_calc_mod.F90)'
2459 0 : EmisL = -1.0
2460 0 : RETURN
2461 : ENDIF
2462 :
2463 0 : IF ( LevDct%Dta%SpaceDim == 1 ) THEN
2464 0 : EmisL = LevDct%Dta%V2(levtidx)%Val(1,1)
2465 0 : ELSEIF ( LevDct%Dta%SpaceDim == 2 ) THEN
2466 0 : EmisL = LevDct%Dta%V2(levtidx)%Val(I,J)
2467 0 : ELSEIF ( LevDct%Dta%SpaceDim == 3 ) THEN
2468 0 : EmisL = LevDct%Dta%V3(levtidx)%Val(I,J,1)
2469 : ENDIF
2470 :
2471 0 : IF ( EmisL == HCO_MISSVAL ) EmisL = 0.0_hp
2472 :
2473 : END FUNCTION GetEmisL
2474 : !EOC
2475 : !------------------------------------------------------------------------------
2476 : ! Harmonized Emissions Component (HEMCO) !
2477 : !------------------------------------------------------------------------------
2478 : !BOP
2479 : !
2480 : ! !FUNCTION: GetEmisLUnit
2481 : !
2482 : ! !DESCRIPTION: Returns the emission level unit read from a scale factor.
2483 : !\\
2484 : !\\
2485 : ! !INTERFACE:
2486 : !
2487 0 : FUNCTION GetEmisLUnit( HcoState, LevDct ) RESULT( EmisLUnit )
2488 : !
2489 : ! !USES:
2490 : !
2491 : USE HCO_TYPES_MOD
2492 : USE HCO_STATE_MOD, ONLY : HCO_State
2493 : !
2494 : ! !INPUT PARAMETERS:
2495 : !
2496 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2497 : TYPE(DataCont), POINTER :: LevDct ! Level index 1 container
2498 : !
2499 : ! !RETURN VALUE:
2500 : !
2501 : INTEGER :: EmisLUnit
2502 : !
2503 : ! !REVISION HISTORY:
2504 : ! 26 Jan 2018 - C. Keller - Initial version
2505 : ! See https://github.com/geoschem/hemco for complete history
2506 : !EOP
2507 : !------------------------------------------------------------------------------
2508 : !BOC
2509 : !
2510 : ! !LOCAL VARIABLES:
2511 : !
2512 : !=================================================================
2513 : ! GetEmisLUnit begins here
2514 : !=================================================================
2515 :
2516 : ! For now, only meters are supported
2517 0 : EmisLUnit = HCO_EMISL_M
2518 :
2519 : ! Dummy check that units on field are actually in meters
2520 0 : IF ( TRIM(LevDct%Dta%OrigUnit) /= 'm' .AND. &
2521 : TRIM(LevDct%Dta%OrigUnit) /= '1' ) THEN
2522 : WRITE(*,*) TRIM(LevDct%cName)// &
2523 : ' must have units of `m`, instead found '//&
2524 0 : TRIM(LevDct%Dta%OrigUnit)//': GetEmisLUnit (hco_calc_mod.F90)'
2525 0 : EmisLUnit = -1
2526 : ENDIF
2527 :
2528 0 : END FUNCTION GetEmisLUnit
2529 : !EOC
2530 : !------------------------------------------------------------------------------
2531 : ! Harmonized Emissions Component (HEMCO) !
2532 : !------------------------------------------------------------------------------
2533 : !BOP
2534 : !
2535 : ! !IROUTINE: GetIdx
2536 : !
2537 : ! !DESCRIPTION: Subroutine GetIdx is a helper routine to return the vertical
2538 : ! level index for a given altitude. The altitude can be provided in level
2539 : ! coordinates, in units of meters or as the 'PBL mixing height'.
2540 : !\\
2541 : !\\
2542 : ! !INTERFACE:
2543 : !
2544 0 : SUBROUTINE GetIdx( HcoState, I, J, alt, altu, lidx, RC )
2545 : !
2546 : ! !USES:
2547 : !
2548 : USE HCO_TYPES_MOD
2549 : USE HCO_STATE_MOD, ONLY : HCO_STATE
2550 : !
2551 : ! !INPUT PARAMETERS:
2552 : !
2553 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2554 : INTEGER, INTENT(IN ) :: I, J ! horizontal index
2555 : INTEGER, INTENT(IN ) :: altu ! altitude unit
2556 : !
2557 : ! !OUTPUT PARAMETERS:
2558 : !
2559 : INTEGER, INTENT( OUT) :: lidx ! level index
2560 : !
2561 : ! !INPUT/OUTPUT PARAMETERS:
2562 : !
2563 : REAL(hp), INTENT(INOUT) :: alt ! altitude
2564 : INTEGER, INTENT(INOUT) :: RC
2565 : !
2566 : ! !REVISION HISTORY:
2567 : ! 09 May 2016 - C. Keller - Initial version
2568 : ! See https://github.com/geoschem/hemco for complete history
2569 : !EOP
2570 : !------------------------------------------------------------------------------
2571 : !BOC
2572 : !
2573 : ! !LOCAL VARIABLES:
2574 : !
2575 : INTEGER :: L
2576 : REAL(hp) :: altb, altt
2577 : CHARACTER(LEN=255) :: MSG
2578 : CHARACTER(LEN=255) :: LOC = 'GetIdx (hco_calc_mod.F90)'
2579 :
2580 : !=================================================================
2581 : ! HCO_GetVertIndx begins here
2582 : !=================================================================
2583 :
2584 : ! Init
2585 0 : RC = HCO_SUCCESS
2586 :
2587 : ! Simple case: data is already on level unit
2588 0 : IF ( altu == HCO_EMISL_LEV ) THEN
2589 0 : lidx = INT(alt)
2590 :
2591 0 : ELSEIF ( altu == HCO_EMISL_TOP ) THEN
2592 0 : lidx = HCOState%NZ
2593 :
2594 0 : ELSEIF ( altu == HCO_EMISL_M .OR. altu == HCO_EMISL_PBL ) THEN
2595 :
2596 : ! Eventually get altitude from PBL height
2597 0 : IF ( altu == HCO_EMISL_PBL ) THEN
2598 0 : alt = HcoState%Grid%PBLHEIGHT%Val(I,J)
2599 : ENDIF
2600 :
2601 : ! Special case of negative height
2602 0 : IF ( alt <= 0.0_hp ) THEN
2603 0 : lidx = 1
2604 0 : RETURN
2605 : ENDIF
2606 :
2607 : ! Loop over data until we are within desired level
2608 : ! NOTE: This can be rewritten more efficiently (bmy, 3/5/21)
2609 0 : altt = 0.0_hp
2610 0 : altb = 0.0_hp
2611 0 : lidx = -1
2612 0 : DO L = 1, HcoState%NZ
2613 0 : altt = altb + HcoState%Grid%BXHEIGHT_M%Val(I,J,L)
2614 0 : IF ( alt >= altb .AND. alt < altt ) THEN
2615 0 : lidx = L
2616 0 : RETURN
2617 : ENDIF
2618 0 : altb = altt
2619 : ENDDO
2620 :
2621 : ! If altitude is above maximum level
2622 0 : IF ( lidx == -1 .AND. alt >= altt ) THEN
2623 0 : lidx = HcoState%NZ
2624 0 : WRITE(MSG,*) 'Level is above max. grid box level - use top level ', alt
2625 0 : CALL HCO_WARNING ( HcoState%Config%Err, MSG, RC, THISLOC=LOC, WARNLEV=2 )
2626 0 : RETURN
2627 : ENDIF
2628 :
2629 : ELSE
2630 0 : MSG = 'Illegal altitude unit'
2631 0 : CALL HCO_ERROR ( MSG, RC, THISLOC=LOC )
2632 0 : RETURN
2633 : ENDIF
2634 :
2635 : ! Return w/ success
2636 0 : RC = HCO_SUCCESS
2637 :
2638 : END SUBROUTINE GetIdx
2639 : !EOC
2640 : !------------------------------------------------------------------------------
2641 : ! Harmonized Emissions Component (HEMCO) !
2642 : !------------------------------------------------------------------------------
2643 : !BOP
2644 : !
2645 : ! !IROUTINE: GetDilFact
2646 : !
2647 : ! !DESCRIPTION: Subroutine GetDilFact returns the vertical dilution factor,
2648 : ! that is the factor that is to be applied to distribute emissions into
2649 : ! multiple vertical levels. If grid box height information are available,
2650 : ! these are used to compute the distribution factor. Otherwise, equal weight
2651 : ! is given to all vertical levels.
2652 : !\\
2653 : !\\
2654 : ! !TODO: Dilution factors are currently only weighted by grid box heights
2655 : ! (if these information are available) but any pressure information are
2656 : ! ignored.
2657 : !\\
2658 : !\\
2659 : ! !INTERFACE:
2660 : !
2661 0 : SUBROUTINE GetDilFact( HcoState, EmisL1, EmisL1Unit, EmisL2, &
2662 : EmisL2Unit, I, J, L, &
2663 : LowLL, UppLL, DilFact, RC )
2664 : !
2665 : ! !USES:
2666 : !
2667 : USE HCO_STATE_MOD, ONLY : HCO_State
2668 : !
2669 : ! !INPUT PARAMETERS:
2670 : !
2671 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2672 : INTEGER, INTENT(IN) :: I ! lon index
2673 : INTEGER, INTENT(IN) :: J ! lat index
2674 : INTEGER, INTENT(IN) :: L ! lev index
2675 : INTEGER, INTENT(IN) :: LowLL ! lower level index
2676 : INTEGER, INTENT(IN) :: UppLL ! upper level index
2677 : !
2678 : ! !OUTPUT PARAMETERS:
2679 : !
2680 : REAL(hp), INTENT(OUT) :: DilFact ! Dilution factor
2681 : !
2682 : ! !INPUT/OUTPUT PARAMETERS:
2683 : !
2684 : REAL(hp), INTENT(INOUT) :: EmisL1
2685 : INTEGER, INTENT(INOUT) :: EmisL1Unit
2686 : REAL(hp), INTENT(INOUT) :: EmisL2
2687 : INTEGER, INTENT(INOUT) :: EmisL2Unit
2688 : INTEGER, INTENT(INOUT) :: RC
2689 : !
2690 : ! !REVISION HISTORY:
2691 : ! 06 May 2016 - C. Keller - Initial Version
2692 : ! See https://github.com/geoschem/hemco for complete history
2693 : !EOP
2694 : !------------------------------------------------------------------------------
2695 : !BOC
2696 : !
2697 : ! !LOCAL VARIABLES:
2698 : !
2699 : INTEGER :: L1
2700 : CHARACTER(LEN=255) :: MSG
2701 : CHARACTER(LEN=255) :: LOC = 'GetDilFact (hco_calc_mod.F90)'
2702 : REAL(hp) :: h1, h2, dh, dh1, dh2
2703 : REAL(hp) :: UppLLR, LowLLR
2704 :
2705 : !=================================================================
2706 : ! GetDilFact begins here
2707 : !=================================================================
2708 :
2709 : ! Init
2710 0 : DilFact = 1.0_hp
2711 0 : RC = HCO_SUCCESS
2712 :
2713 : ! Nothing to do if it's only one level
2714 0 : IF ( LowLL == UppLL ) RETURN
2715 :
2716 : ! Compute dilution factor based on boxheights if this information
2717 : ! is available
2718 0 : IF ( ASSOCIATED( HcoState%Grid%BXHEIGHT_M%Val ) ) THEN
2719 :
2720 : ! Get height of bottom level LowLL (in m)
2721 0 : IF ( EmisL1Unit == HCO_EMISL_M ) THEN
2722 0 : h1 = EmisL1
2723 0 : ELSEIF ( EmisL1Unit == HCO_EMISL_PBL ) THEN
2724 0 : h1 = HcoState%Grid%PBLHEIGHT%Val(I,J)
2725 : ELSE
2726 0 : IF ( LowLL > 1 ) THEN
2727 0 : h1 = SUM(HcoState%Grid%BXHEIGHT_M%Val(I,J,1:(LowLL-1)))
2728 : ELSE
2729 : h1 = 0.0_hp
2730 : ENDIF
2731 : ENDIF
2732 :
2733 : ! Get height of top level UppLL (in m)
2734 0 : IF ( EmisL2Unit == HCO_EMISL_M ) THEN
2735 0 : h2 = EmisL2
2736 0 : ELSEIF ( EmisL2Unit == HCO_EMISL_PBL ) THEN
2737 0 : h2 = HcoState%Grid%PBLHEIGHT%Val(I,J)
2738 : ELSE
2739 0 : h2 = SUM(HcoState%Grid%BXHEIGHT_M%Val(I,J,1:UppLL))
2740 : ENDIF
2741 :
2742 : ! If vertical weight option is enabled, calculate vertical
2743 : ! distribution factor relative to the grid cell heights. This
2744 : ! is the default (and recommended) option as this makes sure
2745 : ! that the same amount of mass is emitted into each layer.
2746 0 : IF ( HcoState%Options%VertWeight ) THEN
2747 :
2748 : ! Height of grid box of interest (in m)
2749 0 : dh = HcoState%Grid%BXHEIGHT_M%Val(I,J,L)
2750 :
2751 : ! Adjust dh if we are in lowest level
2752 0 : IF ( L == LowLL ) THEN
2753 0 : dh = SUM(HcoState%Grid%BXHEIGHT_M%Val(I,J,1:LowLL)) - h1
2754 : ENDIF
2755 :
2756 : ! Adjust dh if we are in top level
2757 0 : IF ( L == UppLL ) THEN
2758 0 : dh = h2 - SUM(HcoState%Grid%BXHEIGHT_M%Val(I,J,1:(UppLL-1)))
2759 : ENDIF
2760 :
2761 : ! compute dilution factor: the new flux should emit the same mass per
2762 : ! volume, i.e. flux_total/column_total = flux_level/column_level
2763 : ! --> flux_level = fluxtotal * column_level / column_total.
2764 0 : IF ( h2 > h1 ) THEN
2765 0 : DilFact = dh / ( h2 - h1 )
2766 : ELSE
2767 0 : MSG = 'GetDilFact h2 not greater than h1'
2768 0 : CALL HCO_ERROR ( HcoState%Config%Err, MSG, RC, THISLOC=LOC )
2769 0 : RETURN
2770 : ENDIF
2771 :
2772 : ! If VertWeight option is turned off, emit the same flux in each layer.
2773 : ! Since model layers have different depths, this will result in differnt
2774 : ! total emissions per layer.
2775 : ELSE
2776 :
2777 : ! Get fractional layer indeces for lower and upper level. This makes
2778 : ! sure that only fractions of the lower and upper level are being
2779 : ! considered, so that double-counting is avoided if a model layer
2780 : ! serves both as the top layer and the bottom layer (e.g., wildfire
2781 : ! emissions emitted from bottom to the top of PBL, and from the top
2782 : ! of PBL to 5000m).
2783 0 : LowLLR = REAL(LowLL,hp) - 1.0_hp
2784 0 : UppLLR = REAL(UppLL,hp)
2785 0 : dh1 = 0.0_hp
2786 0 : DO L1 = 1, HcoState%NZ
2787 0 : dh2 = SUM(HcoState%Grid%BXHEIGHT_M%Val(I,J,1:L1))
2788 0 : IF ( h1 >= dh1 .AND. h1 < dh2 ) THEN
2789 0 : LowLLR = REAL(L1,hp) - ( (dh2-h1)/(dh2-dh1) )
2790 : ENDIF
2791 0 : IF ( h2 > dh1 .AND. h2 <= dh2 ) THEN
2792 0 : UppLLR = REAL(L1,hp) - ( (dh2-h2)/(dh2-dh1) )
2793 : ENDIF
2794 : ! top layer is bottom layer in next loop
2795 0 : dh1 = dh2
2796 : ENDDO
2797 :
2798 : ! Dilution factor using fractional levels
2799 0 : IF ( UppLLR <= LowLLR ) THEN
2800 0 : DilFact = 1.0_hp / REAL(UppLL-LowLL+1,hp)
2801 : ELSE
2802 0 : DilFact = 1.0_hp / (UppLLR-LowLLR)
2803 : ENDIF
2804 :
2805 : ENDIF
2806 :
2807 : ! Approximate dilution factor otherwise
2808 : ELSE
2809 :
2810 0 : DilFact = 1.0_hp / REAL(UppLL-LowLL+1,hp)
2811 : ENDIF
2812 :
2813 : ! Return w/ success
2814 0 : RC = HCO_SUCCESS
2815 :
2816 : END SUBROUTINE GetDilFact
2817 : #ifdef ADJOINT
2818 : !BOP
2819 : !
2820 : ! !IROUTINE: Get_Current_Emissions
2821 : !
2822 : ! !DESCRIPTION: Subroutine Get\_Current\_Emissions calculates the current
2823 : ! emissions for the specified emission container.
2824 : ! This subroutine is only called by HCO\_CalcEmis and for base emission
2825 : ! containers, i.e. containers of type 1.
2826 : !\\
2827 : !\\
2828 : ! !INTERFACE:
2829 : !
2830 : SUBROUTINE Get_Current_Emissions_Adj( HcoState, BaseDct, &
2831 : nI, nJ, nL, OUTARR_3D, MASK, RC, UseLL )
2832 : !
2833 : ! !USES:
2834 : !
2835 : USE HCO_State_Mod, ONLY : HCO_State
2836 : USE HCO_tIdx_MOD, ONLY : tIDx_GetIndx
2837 : USE HCO_FileData_Mod, ONLY : FileData_ArrIsDefined
2838 : !
2839 : ! !INPUT PARAMETERS:
2840 : !
2841 : INTEGER, INTENT(IN) :: nI ! # of lons
2842 : INTEGER, INTENT(IN) :: nJ ! # of lats
2843 : INTEGER, INTENT(IN) :: nL ! # of levs
2844 : !
2845 : ! !INPUT/OUTPUT PARAMETERS:
2846 : !
2847 :
2848 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state object
2849 : TYPE(DataCont), POINTER :: BaseDct ! base emission
2850 : ! container
2851 : REAL(hp), INTENT(INOUT) :: OUTARR_3D(nI,nJ,nL) ! output array
2852 : REAL(hp), INTENT(INOUT) :: MASK (nI,nJ,nL) ! mask array
2853 : INTEGER, INTENT(INOUT) :: RC
2854 : !
2855 : ! !OUTPUT PARAMETERS:
2856 : !
2857 : INTEGER, INTENT( OUT), OPTIONAL :: UseLL
2858 : !
2859 : ! !REMARKS:
2860 : ! This routine uses multiple loops over all grid boxes (base emissions
2861 : ! and scale factors use separate loops). In an OMP environment, this approach
2862 : ! seems to be faster than using only one single loop (but repeated calls to
2863 : ! point to containers, etc.). The alternative approach is used in routine
2864 : ! Get\_Current\_Emissions\_B at the end of this module and may be employed
2865 : ! on request.
2866 : !
2867 : ! !REVISION HISTORY:
2868 : ! 25 Aug 2012 - C. Keller - Initial Version
2869 : ! 09 Nov 2012 - C. Keller - MASK update. Masks are now treated
2870 : ! separately so that multiple masks can be
2871 : ! added.
2872 : ! 06 Jun 2014 - R. Yantosca - Cosmetic changes in ProTeX headers
2873 : ! 07 Sep 2014 - C. Keller - Mask update. Now set mask to zero as soon as
2874 : ! on of the applied masks is zero.
2875 : ! 03 Dec 2014 - C. Keller - Now calculate time slice index on-the-fly.
2876 : ! 29 Dec 2014 - C. Keller - Added scale factor masks.
2877 : ! 02 Mar 2015 - C. Keller - Now check for missing values. Missing values are
2878 : ! excluded from emission calculation.
2879 : ! 26 Oct 2016 - R. Yantosca - Don't nullify local ptrs in declaration stmts
2880 : ! 11 May 2017 - C. Keller - Added universal scaling
2881 : !EOP
2882 : !------------------------------------------------------------------------------
2883 : !BOC
2884 : !
2885 : ! !LOCAL VARIABLES:
2886 : !
2887 : ! Pointers
2888 : TYPE(DataCont), POINTER :: ScalDct
2889 : TYPE(DataCont), POINTER :: MaskDct
2890 : TYPE(DataCont), POINTER :: LevDct1
2891 : TYPE(DataCont), POINTER :: LevDct2
2892 :
2893 : ! Scalars
2894 : REAL(sp) :: TMPVAL, MaskScale
2895 : REAL(hp) :: DilFact
2896 : REAL(hp) :: ScalFact
2897 : INTEGER :: tIDx, IDX
2898 : INTEGER :: I, J, L, N
2899 : INTEGER :: LowLL, UppLL, ScalLL, TmpLL
2900 : INTEGER :: ERROR
2901 : INTEGER :: TotLL, nnLL
2902 : CHARACTER(LEN=255) :: MSG, LOC
2903 : LOGICAL :: NegScalExist
2904 : LOGICAL :: MaskFractions
2905 : LOGICAL :: isLevDct1
2906 : LOGICAL :: isLevDct2
2907 : LOGICAL :: isMaskDct
2908 : LOGICAL :: isPblHt
2909 : LOGICAL :: isBoxHt
2910 : INTEGER :: LevDct1_Unit
2911 : INTEGER :: LevDct2_Unit
2912 :
2913 : ! testing only
2914 : INTEGER :: IX, IY
2915 :
2916 : !=================================================================
2917 : ! GET_CURRENT_EMISSIONS begins here
2918 : !=================================================================
2919 :
2920 : ! Initialize
2921 : ScalDct => NULL()
2922 : MaskDct => NULL()
2923 : LOC = 'GET_CURRENT_EMISSIONS_ADJ (hco_calc_mod.F90)'
2924 :
2925 : ! Enter
2926 : CALL HCO_ENTER(HcoState%Config%Err, LOC, RC )
2927 : IF(RC /= HCO_SUCCESS) RETURN
2928 :
2929 : ! testing only:
2930 : IX = 3 !-1
2931 : IY = 8 !-1
2932 :
2933 : ! Check if container contains data
2934 : IF ( .NOT. FileData_ArrIsDefined(BaseDct%Dta) ) THEN
2935 : MSG = 'Array not defined: ' // TRIM(BaseDct%cName)
2936 : CALL HCO_ERROR( MSG, RC )
2937 : RETURN
2938 : ENDIF
2939 :
2940 : ! Initialize mask. By default, assume that we use all grid boxes.
2941 : MASK(:,:,:) = 1.0_hp
2942 : MaskFractions = HcoState%Options%MaskFractions
2943 :
2944 : ! Verbose
2945 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
2946 : WRITE(MSG,*) 'Evaluate field ', TRIM(BaseDct%cName)
2947 : CALL HCO_MSG(HcoState%Config%Err,MSG,SEP1=' ')
2948 : ENDIF
2949 :
2950 : ! ----------------------------------------------------------------
2951 : ! Set base emissions
2952 : ! ----------------------------------------------------------------
2953 :
2954 : ! Initialize ERROR. Will be set to 1 if error occurs below
2955 : ERROR = 0
2956 :
2957 : ! Initialize variables to compute average vertical level index
2958 : totLL = 0
2959 : nnLL = 0
2960 :
2961 : ! Check for level index containers
2962 : IF ( BaseDct%levScalID1 > 0 ) THEN
2963 : CALL Pnt2DataCont( HcoState, BaseDct%levScalID1, LevDct1, RC )
2964 : IF ( RC /= HCO_SUCCESS ) THEN
2965 : CALL HCO_ERROR( 'ERROR 18', RC, THISLOC=LOC )
2966 : RETURN
2967 : ENDIF
2968 : ELSE
2969 : LevDct1 => NULL()
2970 : ENDIF
2971 : IF ( BaseDct%levScalID2 > 0 ) THEN
2972 : CALL Pnt2DataCont( HcoState, BaseDct%levScalID2, LevDct2, RC )
2973 : IF ( RC /= HCO_SUCCESS ) THEN
2974 : CALL HCO_ERROR( 'ERROR 19', RC, THISLOC=LOC )
2975 : RETURN
2976 : ENDIF
2977 : ELSE
2978 : LevDct2 => NULL()
2979 : ENDIF
2980 :
2981 : ! Test whether LevDct1 and LevDct2 are associated
2982 : isLevDct1 = ASSOCIATED( LevDct1 )
2983 : isLevDct2 = ASSOCIATED( LevDct2 )
2984 :
2985 : ! Get the units of LevDct1 (if it exists)
2986 : IF ( isLevDct1 ) THEN
2987 : LevDct1_Unit = GetEmisLUnit( HcoState, LevDct1 )
2988 : IF ( LevDct1_Unit < 0 ) THEN
2989 : MSG = 'LevDct1 units are not defined!'
2990 : CALL HCO_ERROR ( HcoState%Config%Err, MSG, RC, THISLOC=LOC )
2991 : RC = HCO_FAIL
2992 : RETURN
2993 : ENDIF
2994 : ELSE
2995 : LevDct1_Unit = -1
2996 : ENDIF
2997 :
2998 : ! Get the units of LevDct2 (if it exists)
2999 : IF ( isLevDct2 ) THEN
3000 : LevDct2_Unit = GetEmisLUnit( HcoState, LevDct2 )
3001 : IF ( LevDct2_Unit < 0 ) THEN
3002 : MSG = 'LevDct2_Units are not defined!'
3003 : CALL HCO_ERROR ( HcoState%Config%Err, MSG, RC, THISLOC=LOC )
3004 : RETURN
3005 : ENDIF
3006 : ELSE
3007 : LevDct2_Unit = -1
3008 : ENDIF
3009 :
3010 : ! Throw an error if boxheight is missing and the units are in meters
3011 : IF ( LevDct1_Unit == HCO_EMISL_M .or. &
3012 : LevDct2_Unit == HCO_EMISL_M ) THEN
3013 : IF ( .NOT. ASSOCIATED(HcoState%Grid%BXHEIGHT_M%Val) ) THEN
3014 : MSG = 'Boxheight (in meters) is missing in HEMCO state'
3015 : CALL HCO_ERROR ( HcoState%Config%Err, MSG, RC, THISLOC=LOC )
3016 : RETURN
3017 : ENDIF
3018 : ENDIF
3019 :
3020 : ! Throw an error if boxheight is missing and the units are in PBL frac
3021 : IF ( LevDct1_Unit == HCO_EMISL_PBL .or. &
3022 : LevDct2_Unit == HCO_EMISL_PBL ) THEN
3023 : IF ( .NOT. ASSOCIATED(HcoState%Grid%PBLHEIGHT%Val) ) THEN
3024 : MSG = 'Boundary layer height is missing in HEMCO state'
3025 : CALL HCO_ERROR ( HcoState%Config%Err, MSG, RC, THISLOC=LOC )
3026 : RETURN
3027 : ENDIF
3028 : ENDIF
3029 :
3030 : ! Loop over all latitudes and longitudes
3031 : !$OMP PARALLEL DO &
3032 : !$OMP DEFAULT( SHARED )&
3033 : !$OMP PRIVATE( I, J, L, tIdx, TMPVAL, DilFact, LowLL, UppLL )&
3034 : !$OMP COLLAPSE( 2 )&
3035 : !$OMP SCHEDULE( DYNAMIC, 4 )&
3036 : !$OMP REDUCTION( +:totLL )&
3037 : !$OMP REDUCTION( +:nnLL )
3038 : DO J = 1, nJ
3039 : DO I = 1, nI
3040 :
3041 : ! Zero for safety's sake
3042 : totLL = 0
3043 : nnLL = 0
3044 :
3045 : ! Get current time index for this container and at this location
3046 : tIDx = tIDx_GetIndx( HcoState, BaseDct%Dta, I, J )
3047 : IF ( tIDx < 1 ) THEN
3048 : WRITE(MSG,*) 'Cannot get time slice index at location ',I,J,&
3049 : ': ', TRIM(BaseDct%cName), tIDx
3050 : ERROR = 1
3051 : EXIT
3052 : ENDIF
3053 :
3054 : ! Get lower and upper vertical index
3055 : CALL GetVertIndx ( HcoState, BaseDct, isLevDct1, LevDct1, &
3056 : LevDct1_Unit, isLevDct2, LevDct2, LevDct2_Unit, &
3057 : I, J, LowLL, UppLL, &
3058 : RC )
3059 : IF ( RC /= HCO_SUCCESS ) THEN
3060 : WRITE(MSG,*) 'Error getting vertical index at location ',I,J,&
3061 : ': ', TRIM(BaseDct%cName)
3062 : ERROR = 1 ! Will cause error
3063 : EXIT
3064 : ENDIF
3065 :
3066 : ! average upper level
3067 : totLL = totLL + UppLL
3068 : nnLL = nnLL + 1
3069 :
3070 : ! Loop over all levels
3071 : DO L = LowLL, UppLL
3072 :
3073 : ! Get base value. Use uniform value if scalar field.
3074 : IF ( BaseDct%Dta%SpaceDim == 1 ) THEN
3075 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(1,1)
3076 : ELSEIF ( BaseDct%Dta%SpaceDim == 2 ) THEN
3077 : TMPVAL = BaseDct%Dta%V2(tIDx)%Val(I,J)
3078 : ELSE
3079 : TMPVAL = BaseDct%Dta%V3(tIDx)%Val(I,J,L)
3080 : ENDIF
3081 :
3082 : ! If it's a missing value, mask box as unused and set value to zero
3083 : IF ( TMPVAL == HCO_MISSVAL ) THEN
3084 : MASK(I,J,:) = 0.0_hp
3085 : OUTARR_3D(I,J,L) = 0.0_hp
3086 :
3087 : ! Pass base value to output array
3088 : ELSE
3089 :
3090 : ! Get dilution factor. Never dilute 3D emissions.
3091 : IF ( BaseDct%Dta%SpaceDim == 3 ) THEN
3092 : DilFact = 1.0_hp !1.0
3093 :
3094 : ! 2D dilution factor
3095 : ELSE
3096 : CALL GetDilFact ( HcoState, BaseDct%Dta%EmisL1, &
3097 : BaseDct%Dta%EmisL1Unit, BaseDct%Dta%EmisL2, &
3098 : BaseDct%Dta%EmisL2Unit, I, J, L, LowLL, &
3099 : UppLL, DilFact, RC )
3100 : IF ( RC /= HCO_SUCCESS ) THEN
3101 : WRITE(MSG,*) 'Error getting dilution factor at ',I,J,&
3102 : ': ', TRIM(BaseDct%cName)
3103 : ERROR = 1
3104 : EXIT
3105 : ENDIF
3106 : ENDIF
3107 :
3108 : ! Scale base emission by dilution factor
3109 : OUTARR_3D(I,J,L) = DilFact * TMPVAL
3110 : ENDIF
3111 : ENDDO !L
3112 :
3113 : ENDDO !I
3114 : ENDDO !J
3115 : !$OMP END PARALLEL DO
3116 :
3117 : ! Check for error
3118 : IF ( ERROR == 1 ) THEN
3119 : CALL HCO_ERROR( MSG, RC )
3120 : RETURN
3121 : ENDIF
3122 :
3123 : ! ----------------------------------------------------------------
3124 : ! Apply scale factors
3125 : ! The container IDs of all scale factors associated with this base
3126 : ! container are stored in vector Scal_cID.
3127 : ! ----------------------------------------------------------------
3128 :
3129 : ! Loop over scale factors
3130 : IF ( BaseDct%nScalID > 0 ) THEN
3131 :
3132 : DO N = 1, BaseDct%nScalID
3133 :
3134 : ! Get the scale factor container ID for the current slot
3135 : IDX = BaseDct%Scal_cID(N)
3136 :
3137 : ! Point to data container with the given container ID
3138 : CALL Pnt2DataCont( HcoState, IDX, ScalDct, RC )
3139 : IF ( RC /= HCO_SUCCESS ) THEN
3140 : CALL HCO_ERROR( 'ERROR 20', RC, THISLOC=LOC )
3141 : RETURN
3142 : ENDIF
3143 :
3144 : ! Sanity check: scale field cannot be a base field
3145 : IF ( (ScalDct%DctType == HCO_DCTTYPE_BASE) ) THEN
3146 : MSG = 'Wrong scale field type: ' // TRIM(ScalDct%cName)
3147 : CALL HCO_ERROR( MSG, RC )
3148 : RETURN
3149 : ENDIF
3150 :
3151 : ! Skip this scale factor if no data defined. This is possible
3152 : ! if scale factors are only defined for a given time range and
3153 : ! the simulation datetime is outside of this range.
3154 : IF ( .NOT. FileData_ArrIsDefined(ScalDct%Dta) ) THEN
3155 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
3156 : MSG = 'Skip scale factor '//TRIM(ScalDct%cName)// &
3157 : ' because it is not defined for this datetime.'
3158 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3159 : ENDIF
3160 : CYCLE
3161 : ENDIF
3162 :
3163 : ! Verbose mode
3164 : IF ( HCO_IsVerb(HcoState%Config%Err,2) ) THEN
3165 : MSG = 'Applying scale factor ' // TRIM(ScalDct%cName)
3166 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3167 : ENDIF
3168 :
3169 : ! Get vertical extension of this scale factor array.
3170 : IF( (ScalDct%Dta%SpaceDim<=2) ) THEN
3171 : ScalLL = 1
3172 : ELSE
3173 : ScalLL = SIZE(ScalDct%Dta%V3(1)%Val,3)
3174 : ENDIF
3175 :
3176 : ! Check if there is a mask field associated with this scale
3177 : ! factor. In this case, get a pointer to the corresponding
3178 : ! mask field and evaluate scale factors only inside the mask
3179 : ! region.
3180 : IF ( ASSOCIATED(ScalDct%Scal_cID) ) THEN
3181 : CALL Pnt2DataCont( HcoState, ScalDct%Scal_cID(1), MaskDct, RC )
3182 : IF ( RC /= HCO_SUCCESS ) THEN
3183 : CALL HCO_ERROR( 'ERROR 21', RC, THISLOC=LOC )
3184 : RETURN
3185 : ENDIF
3186 :
3187 : ! Must be mask field
3188 : IF ( MaskDct%DctType /= HCO_DCTTYPE_MASK ) THEN
3189 : MSG = 'Invalid mask for scale factor: '//TRIM(ScalDct%cName)
3190 : MSG = TRIM(MSG) // '; mask: '//TRIM(MaskDct%cName)
3191 : CALL HCO_ERROR( MSG, RC )
3192 : RETURN
3193 : ENDIF
3194 : ENDIF
3195 :
3196 : ! Reinitialize error flag. Will be set to 1 or 2 if error occurs,
3197 : ! and to -1 if negative scale factor is ignored.
3198 : ERROR = 0
3199 :
3200 : ! Loop over all latitudes and longitudes
3201 : !$OMP PARALLEL DO &
3202 : !$OMP DEFAULT( SHARED ) &
3203 : !$OMP PRIVATE( I, J, tIdx, TMPVAL, L, LowLL, UppLL, tmpLL, MaskScale )&
3204 : !$OMP COLLAPSE( 2 )&
3205 : !$OMP SCHEDULE( DYNAMIC, 4 )
3206 : DO J = 1, nJ
3207 : DO I = 1, nI
3208 :
3209 : ! ------------------------------------------------------------
3210 : ! If there is a mask associated with this scale factors, check
3211 : ! if this grid box is within or outside of the mask region.
3212 : ! Values that partially fall into the mask region are either
3213 : ! treated as binary (100% inside or outside), or partially
3214 : ! (using the real grid area fractions), depending on the
3215 : ! HEMCO options.
3216 : ! ------------------------------------------------------------
3217 :
3218 : ! Default mask scaling is 1.0 (no mask applied)
3219 : MaskScale = 1.0_sp
3220 :
3221 : ! If there is a mask applied to this scale factor ...
3222 : IF ( ASSOCIATED(MaskDct) ) THEN
3223 : CALL GetMaskVal ( MaskDct, I, J, &
3224 : MaskScale, MaskFractions, RC )
3225 : IF ( RC /= HCO_SUCCESS ) THEN
3226 : ERROR = 4
3227 : EXIT
3228 : ENDIF
3229 : ENDIF
3230 :
3231 : ! We can skip this grid box if mask is completely zero
3232 : IF ( MaskScale <= 0.0_sp ) CYCLE
3233 :
3234 : ! Get current time index for this container and at this location
3235 : tIDx = tIDx_GetIndx( HcoState, ScalDct%Dta, I, J )
3236 : IF ( tIDx < 1 ) THEN
3237 : WRITE(*,*) 'Cannot get time slice index at location ',I,J,&
3238 : ': ', TRIM(ScalDct%cName), tIDx
3239 : ERROR = 3
3240 : EXIT
3241 : ENDIF
3242 :
3243 : ! Check if this is a mask. If so, add mask values to the MASK
3244 : ! array. For now, we assume masks to be binary, i.e. 0 or 1.
3245 : ! We may want to change that in future to also support values
3246 : ! in between. This is especially important when regridding
3247 : ! high resolution masks onto coarser grids!
3248 : ! ------------------------------------------------------------
3249 : IF ( ScalDct%DctType == HCO_DCTTYPE_MASK ) THEN
3250 :
3251 : ! Get mask value
3252 : CALL GetMaskVal ( ScalDct, I, J, &
3253 : TMPVAL, MaskFractions, RC )
3254 : IF ( RC /= HCO_SUCCESS ) THEN
3255 : ERROR = 4
3256 : EXIT
3257 : ENDIF
3258 :
3259 : ! Pass to output mask
3260 : MASK(I,J,:) = MASK(I,J,:) * TMPVAL
3261 :
3262 : ! testing only
3263 : IF ( HCO_IsVerb(HcoState%Config%Err,2) .AND. I==1 .AND. J==1 ) THEN
3264 : write(MSG,*) 'Mask field ', TRIM(ScalDct%cName), &
3265 : ' found and added to temporary mask.'
3266 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3267 : ENDIF
3268 :
3269 : ! Advance to next grid box
3270 : CYCLE
3271 : ENDIF! DctType=MASK
3272 :
3273 : ! ------------------------------------------------------------
3274 : ! For non-mask fields, apply scale factors to all levels
3275 : ! of the base field individually. If the scale factor
3276 : ! field has more than one vertical level, use the
3277 : ! vertical level closest to the corresponding vertical
3278 : ! level of the base emission field
3279 : ! ------------------------------------------------------------
3280 :
3281 : ! Get lower and upper vertical index
3282 : CALL GetVertIndx( HcoState, BaseDct, isLevDct1, &
3283 : LevDct1, LevDct1_Unit, isLevDct2, &
3284 : LevDct2, LevDct2_Unit, I, &
3285 : J, LowLL, UppLL, RC )
3286 : IF ( RC /= HCO_SUCCESS ) THEN
3287 : ERROR = 1 ! Will cause error
3288 : EXIT
3289 : ENDIF
3290 :
3291 : ! Loop over all vertical levels of the base field
3292 : DO L = LowLL,UppLL
3293 : ! If the vertical level exceeds the number of available
3294 : ! scale factor levels, use the highest available level.
3295 : IF ( L > ScalLL ) THEN
3296 : TmpLL = ScalLL
3297 : ! Otherwise use the same vertical level index.
3298 : ELSE
3299 : TmpLL = L
3300 : ENDIF
3301 :
3302 : ! Get scale factor for this grid box. Use same uniform
3303 : ! value if it's a scalar field
3304 : IF ( ScalDct%Dta%SpaceDim == 1 ) THEN
3305 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(1,1)
3306 : ELSEIF ( ScalDct%Dta%SpaceDim == 2 ) THEN
3307 : TMPVAL = ScalDct%Dta%V2(tidx)%Val(I,J)
3308 : ELSE
3309 : TMPVAL = ScalDct%Dta%V3(tidx)%Val(I,J,TmpLL)
3310 : ENDIF
3311 :
3312 : ! Set missing value to one
3313 : IF ( TMPVAL == HCO_MISSVAL ) TMPVAL = 1.0_sp
3314 :
3315 : ! Eventually apply mask scaling
3316 : IF ( MaskScale /= 1.0_sp ) THEN
3317 : TMPVAL = TMPVAL * MaskScale
3318 : ENDIF
3319 :
3320 : ! For negative scale factor, proceed according to the
3321 : ! negative value setting specified in the configuration
3322 : ! file (NegFlag = 2: use this value):
3323 : IF ( TMPVAL < 0.0_sp .AND. HcoState%Options%NegFlag /= 2 ) THEN
3324 :
3325 : ! NegFlag = 1: ignore and show warning
3326 : IF ( HcoState%Options%NegFlag == 1 ) THEN
3327 : ERROR = -1 ! Will prompt warning
3328 : CYCLE
3329 :
3330 : ! Return w/ error otherwise
3331 : ELSE
3332 : WRITE(*,*) 'Negative scale factor at ',I,J,TmpLL,tidx,&
3333 : ': ', TRIM(ScalDct%cName), TMPVAL
3334 : ERROR = 1 ! Will cause error
3335 : EXIT
3336 : ENDIF
3337 : ENDIF
3338 :
3339 : ! -------------------------------------------------------
3340 : ! Apply scale factor in accordance to field operator
3341 : ! -------------------------------------------------------
3342 :
3343 : ! Oper 1: multiply
3344 : IF ( ScalDct%Oper == 1 ) THEN
3345 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL
3346 :
3347 : ! Oper -1: divide
3348 : ELSEIF ( ScalDct%Oper == -1 ) THEN
3349 : ! Ignore zeros to avoid NaN
3350 : IF ( TMPVAL /= 0.0_sp ) THEN
3351 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) / TMPVAL
3352 : ENDIF
3353 :
3354 : ! Oper 2: square
3355 : ELSEIF ( ScalDct%Oper == 2 ) THEN
3356 : OUTARR_3D(I,J,L) = OUTARR_3D(I,J,L) * TMPVAL * TMPVAL
3357 :
3358 : ! Return w/ error otherwise (Oper 3 is only allowed for masks!)
3359 : ELSE
3360 : WRITE(*,*) 'Illegal operator for ', TRIM(ScalDct%cName), ScalDct%Oper
3361 : ERROR = 2 ! Will cause error
3362 : EXIT
3363 : ENDIF
3364 :
3365 : ENDDO !LL
3366 :
3367 : ! Verbose mode
3368 : if ( HCO_IsVerb(HcoState%Config%Err,3) .and. i == ix .and. j == iy ) then
3369 : write(MSG,*) 'Scale field ', TRIM(ScalDct%cName)
3370 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3371 : write(MSG,*) 'Time slice: ', tIdx
3372 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3373 : write(MSG,*) 'IX, IY: ', IX, IY
3374 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3375 : write(MSG,*) 'Scale factor (IX,IY,L1): ', TMPVAL
3376 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3377 : write(MSG,*) 'Mathematical operation : ', ScalDct%Oper
3378 : CALL HCO_MSG(HcoState%Config%Err,MSG)
3379 : ! write(lun,*) 'Updt (IX,IY,L1): ', OUTARR_3D(IX,IY,1)
3380 : endif
3381 :
3382 : ENDDO !I
3383 : ENDDO !J
3384 : !$OMP END PARALLEL DO
3385 :
3386 : ! error check
3387 : IF ( ERROR > 0 ) THEN
3388 : IF ( ERROR == 1 ) THEN
3389 : MSG = 'Negative scale factor found (aborted): ' // TRIM(ScalDct%cName)
3390 : ELSEIF ( ERROR == 2 ) THEN
3391 : MSG = 'Illegal mathematical operator for scale factor: ' // TRIM(ScalDct%cName)
3392 : ELSEIF ( ERROR == 3 ) THEN
3393 : MSG = 'Encountered negative time index for scale factor: ' // TRIM(ScalDct%cName)
3394 : ELSEIF ( ERROR == 4 ) THEN
3395 : MSG = 'Mask error in ' // TRIM(ScalDct%cName)
3396 : ELSE
3397 : MSG = 'Error when applying scale factor: ' // TRIM(ScalDct%cName)
3398 : ENDIF
3399 : ScalDct => NULL()
3400 : CALL HCO_ERROR( MSG, RC )
3401 : RETURN
3402 : ENDIF
3403 :
3404 : ! eventually prompt warning for negative values
3405 : IF ( ERROR == -1 ) THEN
3406 : MSG = 'Negative scale factor found (ignored): ' // TRIM(ScalDct%cName)
3407 : CALL HCO_WARNING( HcoState%Config%Err, MSG, RC )
3408 : ENDIF
3409 :
3410 : ! Free pointer
3411 : MaskDct => NULL()
3412 :
3413 : ENDDO ! N
3414 : ENDIF ! N > 0
3415 :
3416 : ! Update optional variables
3417 : IF ( PRESENT(UseLL) ) THEN
3418 : UseLL = 1
3419 : IF ( nnLL > 0 ) UseLL = NINT(REAL(TotLL,kind=sp)/REAL(nnLL,kind=sp))
3420 : ENDIF
3421 :
3422 : ! Weight output emissions by mask
3423 : OUTARR_3D = OUTARR_3D * MASK
3424 :
3425 : ! Cleanup and leave w/ success
3426 : ScalDct => NULL()
3427 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
3428 :
3429 : END SUBROUTINE Get_Current_Emissions_Adj
3430 : !EOC
3431 : #endif
3432 : !EOC
3433 : END MODULE HCO_Calc_Mod
|