LCOV - code coverage report
Current view: top level - hemco/HEMCO/src/Core - hco_calc_mod.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 0 665 0.0 %
Date: 2025-03-13 18:55:17 Functions: 0 12 0.0 %

          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

Generated by: LCOV version 1.14