Line data Source code
1 : !------------------------------------------------------------------------------
2 : ! Harmonized Emissions Component (HEMCO) !
3 : !------------------------------------------------------------------------------
4 : !BOP
5 : !
6 : ! !MODULE: hco_emislist_mod.F90
7 : !
8 : ! !DESCRIPTION: Module HCO\_EmisList\_Mod contains routines and variables
9 : ! for the HEMCO emissions list EmisList. EmisList is a sorted collection
10 : ! of all data containers needed for emission calculation. The containers
11 : ! are sorted by data type, species, emission category, and emission
12 : ! hierarchy (in this order).
13 : !\\
14 : !\\
15 : ! !INTERFACE:
16 : !
17 : MODULE HCO_EMISLIST_MOD
18 : !
19 : ! !USES:
20 : !
21 : USE HCO_ERROR_MOD
22 : USE HCO_TYPES_MOD
23 : USE HCO_STATE_MOD, ONLY : HCO_State
24 :
25 : IMPLICIT NONE
26 : PRIVATE
27 : !
28 : ! !PUBLIC MEMBER FUNCTIONS:
29 : !
30 : PUBLIC :: HCO_GetPtr
31 : PUBLIC :: EmisList_Pass
32 : ! PUBLIC :: EmisList_Update
33 : !
34 : ! !PRIVATE MEMBER FUNCTIONS:
35 : !
36 : PRIVATE :: EmisList_Add
37 : PRIVATE :: Add2EmisList
38 : !
39 : ! !REVISION HISTORY:
40 : ! 04 Dec 2012 - C. Keller - Initialization
41 : ! See https://github.com/geoschem/hemco for complete history
42 : !EOP
43 : !------------------------------------------------------------------------------
44 : !BOC
45 : !
46 : ! !PRIVATE TYPES:
47 : !
48 : INTERFACE HCO_GetPtr
49 : MODULE PROCEDURE HCO_GetPtr_2D
50 : MODULE PROCEDURE HCO_GetPtr_3D
51 : END INTERFACE HCO_GetPtr
52 :
53 : CONTAINS
54 : !EOC
55 : !------------------------------------------------------------------------------
56 : ! Harmonized Emissions Component (HEMCO) !
57 : !------------------------------------------------------------------------------
58 : !BOP
59 : !
60 : ! !IROUTINE: EmisList_Add
61 : !
62 : ! !DESCRIPTION: Subroutine EmisList\_Add adds the passed data container
63 : ! Dct to EmisList. Within EmisList, Dct becomes placed with
64 : ! increasing data type, species ID, category and hierarchy (in this order).
65 : !\\
66 : !\\
67 : ! !INTERFACE:
68 : !
69 0 : SUBROUTINE EmisList_Add( Dct, HcoState, RC )
70 : !
71 : ! !USES:
72 : !
73 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
74 : USE HCO_LOGFILE_MOD, ONLY : HCO_PrintDataCont
75 : !
76 : ! !INPUT PARAMETERS:
77 : !
78 : TYPE(DataCont), POINTER :: Dct ! Data cont.
79 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state
80 : !
81 : ! !INPUT/OUTPUT PARAMETERS:
82 : !
83 : INTEGER, INTENT(INOUT) :: RC ! Return code
84 : !
85 : ! !REVISION HISTORY:
86 : ! 04 Dec 2012 - C. Keller - Initial version
87 : ! See https://github.com/geoschem/hemco for complete history
88 : !EOP
89 : !------------------------------------------------------------------------------
90 : !BOC
91 : !
92 : ! !LOCAL ARGUMENTS:
93 : !
94 : TYPE(ListCont), POINTER :: Lct
95 : LOGICAL :: FOUND, VERBOSE, NEW
96 : CHARACTER(LEN=255) :: MSG, LOC
97 : CHARACTER(LEN= 31) :: TempRes
98 :
99 : !======================================================================
100 : ! EmisList_Add begins here!
101 : !======================================================================
102 0 : LOC = 'EmisList_Add (HCO_EMISLIST.F90)'
103 :
104 : ! Enter
105 0 : CALL HCO_ENTER ( HcoState%Config%Err, LOC, RC )
106 0 : IF(RC /= HCO_SUCCESS) RETURN
107 :
108 : ! Set verbose flag
109 0 : VERBOSE = HCO_IsVerb( HcoState%Config%Err )
110 :
111 : ! Init
112 0 : Lct => NULL()
113 :
114 : ! ----------------------------------------------------------------
115 : ! Nothing to do if it's not a new container, i.e. if container
116 : ! already exists in EmisList.
117 : ! ----------------------------------------------------------------
118 0 : CALL ListCont_Find ( HcoState%EmisList, Dct%cID, 0, FOUND, Lct )
119 0 : IF ( FOUND ) THEN
120 0 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
121 0 : RETURN
122 : ENDIF
123 :
124 : ! ----------------------------------------------------------------
125 : ! Define new list container. This container points to the passed
126 : ! data container.
127 : ! ----------------------------------------------------------------
128 0 : ALLOCATE ( Lct )
129 0 : Lct%NextCont => NULL()
130 0 : IF ( .not. ASSOCIATED( Dct ) ) THEN
131 0 : PRINT*, '#### DCT is not associated!'
132 : ENDIF
133 0 : Lct%Dct => Dct
134 :
135 : ! ----------------------------------------------------------------
136 : ! Add the new container to EmisList. The container will be placed
137 : ! according to data type, species ID, hierarchy, and category.
138 : ! ----------------------------------------------------------------
139 0 : CALL Add2EmisList ( HcoState, Lct, RC )
140 0 : IF ( RC /= HCO_SUCCESS ) THEN
141 0 : CALL HCO_ERROR( 'ERROR 0', RC, THISLOC=LOC )
142 0 : RETURN
143 : ENDIF
144 :
145 : ! ----------------------------------------------------------------
146 : ! Verbose mode
147 : ! ----------------------------------------------------------------
148 0 : IF ( VERBOSE ) THEN
149 0 : MSG = 'Container added to EmisList:'
150 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
151 0 : CALL HCO_PrintDataCont( HcoState, Lct%Dct )
152 : ENDIF
153 :
154 : ! Leave w/ success
155 0 : CALL HCO_LEAVE ( HcoState%Config%Err, RC )
156 :
157 : END SUBROUTINE EmisList_Add
158 : !EOC
159 : !------------------------------------------------------------------------------
160 : ! Harmonized Emissions Component (HEMCO) !
161 : !------------------------------------------------------------------------------
162 : !BOP
163 : !
164 : ! !IROUTINE: Add2EmisList
165 : !
166 : ! !DESCRIPTION: Subroutine Add2EmisList adds list container Lct to
167 : ! EmisList. Base emission fields (Data type = 1) are sorted based on
168 : ! species ID, category and hierarchy (for fields of same category). Scale
169 : ! fields and masks are added to the end of EmisList.
170 : !\\
171 : !\\
172 : ! !INTERFACE:
173 : !
174 0 : SUBROUTINE Add2EmisList( HcoState, Lct, RC )
175 : !
176 : ! !INPUT PARAMETERS:
177 : !
178 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state
179 : TYPE(ListCont), POINTER :: Lct
180 : !
181 : ! !INPUT/OUTPUT PARAMETERS:
182 : !
183 : INTEGER, INTENT(INOUT) :: RC
184 : !
185 : ! !REVISION HISTORY:
186 : ! 06 Dec 2012 - C. Keller - Initial version
187 : ! See https://github.com/geoschem/hemco for complete history
188 : !EOP
189 : !------------------------------------------------------------------------------
190 : !BOC
191 : !
192 : ! !LOCAL VARIABLES:
193 : !
194 : ! Scalars
195 : INTEGER :: NEWCAT, NEWHIR, NEWSPC
196 : CHARACTER(LEN=255) :: MSG, LOC
197 :
198 : ! Pointers
199 : TYPE(ListCont), POINTER :: TmpLct => NULL()
200 :
201 : !======================================================================
202 : ! Add2EmisList begins here!
203 : !======================================================================
204 0 : LOC = 'Add2EmisList (HCO_EMISLIST_MOD.F90)'
205 :
206 : ! Enter
207 0 : CALL HCO_ENTER ( HcoState%Config%Err, LOC, RC )
208 0 : IF ( RC /= HCO_SUCCESS ) THEN
209 0 : CALL HCO_ERROR( 'ERROR 1', RC, THISLOC=LOC )
210 0 : RETURN
211 : ENDIF
212 :
213 : ! Update number of containers in EmisList
214 0 : HcoState%nnEmisCont = HcoState%nnEmisCont + 1
215 :
216 : ! Flag the content of this container as being used in EmisList
217 0 : Lct%Dct%Dta%IsInList = .TRUE.
218 :
219 : ! If this is the first container, we can simply place it at the
220 : ! beginning of the list.
221 0 : IF ( HcoState%nnEmisCont == 1 ) THEN
222 0 : HcoState%EmisList => Lct
223 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
224 0 : RETURN ! Leave routine
225 : ENDIF
226 :
227 : ! Special case where the linked list consists of scale factors
228 : ! only: In this case, we can place the new container at the
229 : ! beginning no matter of its content!
230 0 : IF ( HcoState%EmisList%Dct%DctType /= HCO_DCTTYPE_BASE ) THEN
231 0 : Lct%NextCont => HcoState%EmisList
232 0 : HcoState%EmisList => Lct
233 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
234 0 : RETURN
235 : ENDIF
236 :
237 : ! Get field species ID, category and priority of the new container
238 0 : NEWSPC = Lct%Dct%HcoID
239 0 : NEWCAT = Lct%Dct%Cat
240 0 : NEWHIR = Lct%Dct%Hier
241 :
242 : ! Containers are listed with increasing species ID. If the current
243 : ! container has lower speciesID than the first container, just add
244 : ! it at the beginning of the list.
245 0 : IF ( (NEWSPC > 0) .AND. (NEWSPC < HcoState%EmisList%Dct%HcoID) ) THEN
246 0 : Lct%NextCont => HcoState%EmisList
247 0 : HcoState%EmisList => Lct
248 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
249 0 : RETURN
250 : ENDIF
251 :
252 : ! In case that the current container has the same species ID
253 : ! as the first container in the list: If this container has
254 : ! lower category, or same category and lower hierarchy, place
255 : ! it before the first container in the list:
256 0 : IF ( NEWSPC == HcoState%EmisList%Dct%HcoID ) THEN
257 0 : IF ( (HcoState%EmisList%Dct%Cat > NEWCAT) .OR. &
258 : (HcoState%EmisList%Dct%Cat == NEWCAT .AND. &
259 : HcoState%EmisList%Dct%Hier > NEWHIR) ) THEN
260 0 : Lct%NextCont => HcoState%EmisList
261 0 : HcoState%EmisList => Lct
262 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
263 0 : RETURN
264 : ENDIF
265 : ENDIF
266 :
267 : ! TmpLct is the temporary working pointer, looping through
268 : ! the entire EmisList until the correct place for the new
269 : ! container is found.
270 0 : TmpLct => HcoState%EmisList
271 :
272 : ! If the new container contains base data (i.e. data type is 1)
273 : ! we have to move the TmpLct pointer to the position where the
274 : ! next container is also a base container and one of the
275 : ! following: (a) the first container with the same species ID
276 : ! as the new container; (b) a container with higher species ID;
277 : ! (c) scale factors. From there, we can determine where to place
278 : ! the container exactly.
279 0 : IF ( Lct%Dct%DctType == HCO_DCTTYPE_BASE ) THEN
280 :
281 : ! Loop over list
282 0 : DO WHILE ( ASSOCIATED ( TmpLct%NextCont ) )
283 :
284 : ! Check if next container's species ID is higher or if it's a
285 : ! scale factor, in which case we have to exit.
286 0 : IF ( TmpLct%NextCont%Dct%HcoID > NEWSPC .OR. &
287 : TmpLct%NextCont%Dct%DctType /= HCO_DCTTYPE_BASE ) THEN
288 : EXIT
289 : ENDIF
290 :
291 : ! Check if next container has the same species ID but a
292 : ! higher category or the same category but higher hierarchy,
293 : ! in which case we have to exit.
294 0 : IF ( TmpLct%NextCont%Dct%HcoID == NEWSPC ) THEN
295 0 : IF ( TmpLct%NextCont%Dct%Cat > NEWCAT ) THEN
296 : EXIT
297 : ENDIF
298 0 : IF ( TmpLct%NextCont%Dct%Cat == NEWCAT .AND. &
299 : TmpLct%NextCont%Dct%Hier > NEWHIR ) THEN
300 : EXIT
301 : ENDIF
302 : ENDIF
303 :
304 : ! Advance in list if none of the above checks was true.
305 0 : TmpLct => TmpLct%NextCont
306 : ENDDO
307 :
308 : ! Scale factors and masks are collected at the end of the list.
309 : ! Hence, make TmpLct pointer point to the last container w/ base
310 : ! emissions (or the last container in the list).
311 : ELSE
312 :
313 : ! Loop over list
314 0 : DO WHILE ( ASSOCIATED ( TmpLct%NextCont ) )
315 :
316 : ! Check if next container is scale factor
317 0 : IF ( TmpLct%NextCont%Dct%DctType /= HCO_DCTTYPE_BASE ) EXIT
318 :
319 : ! Advance in list
320 0 : TmpLct => TmpLct%NextCont
321 : ENDDO
322 :
323 : ENDIF
324 :
325 : ! Add new container AFTER current one
326 0 : Lct%NextCont => TmpLct%NextCont
327 0 : TmpLct%NextCont => Lct
328 :
329 : ! Cleanup and leave
330 0 : TmpLct => NULL()
331 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
332 :
333 : END SUBROUTINE Add2EmisList
334 : !EOC
335 : !!------------------------------------------------------------------------------
336 : !! Harmonized Emissions Component (HEMCO) !
337 : !!------------------------------------------------------------------------------
338 : !!BOP
339 : !!
340 : !! !IROUTINE: EmisList_Update
341 : !!
342 : !! !DESCRIPTION: Subroutine EmisList\_Update makes sure that all containers
343 : !! of the reading list ReadList are correctly referenced in emissions list
344 : !! EmisList. If a container of ReadList does not yet have a corresponding
345 : !! container in EmisList, such a container is created. Also, additive data
346 : !! arrays (i.e. targetID different than container ID) are added to their
347 : !! target array during this call.
348 : !!\\
349 : !!\\
350 : !! !INTERFACE:
351 : !!
352 : ! SUBROUTINE EmisList_Update ( HcoState, ReadList, RC )
353 : !!
354 : !! !USES:
355 : !!
356 : ! USE HCO_FILEDATA_MOD, ONLY : FileData_ArrIsDefined
357 : !!
358 : !! !INPUT PARAMETERS:
359 : !!
360 : ! TYPE(HCO_State), POINTER :: HcoState ! Hemco state object
361 : ! TYPE(ListCont), POINTER :: ReadList ! reading list
362 : !!
363 : !! !INPUT/OUTPUT PARAMETERS:
364 : !!
365 : ! INTEGER, INTENT(INOUT) :: RC ! Return code
366 : !!
367 : !! !REVISION HISTORY:
368 : !! 20 Apr 2013 - C. Keller - Initial version
369 : !! See https://github.com/geoschem/hemco for complete history
370 : !!EOP
371 : !!------------------------------------------------------------------------------
372 : !!BOC
373 : !!
374 : !! !LOCAL VARIABLES:
375 : !!
376 : ! ! Scalars
377 : ! INTEGER :: cID, iScalID
378 : ! INTEGER :: I
379 : ! CHARACTER(LEN=31) :: ScalName
380 : !
381 : ! ! Pointers
382 : ! TYPE(ListCont), POINTER :: TmpLct => NULL()
383 : !
384 : ! ! ================================================================
385 : ! ! EmisList_Update begins here
386 : ! ! ================================================================
387 : !
388 : ! ! Enter
389 : ! CALL HCO_ENTER ( HcoState%Config%Err, 'EmisList_Update', RC )
390 : ! IF ( RC /= HCO_SUCCESS ) RETURN
391 : !
392 : ! ! Loop over all containers in ReadList
393 : ! TmpLct => ReadList
394 : ! DO WHILE ( ASSOCIATED( TmpLct ) )
395 : !
396 : ! ! only if array is defined...
397 : ! IF ( FileData_ArrIsDefined(TmpLct%Dct%Dta) ) THEN
398 : !
399 : ! ! Pass container to EmisList
400 : ! CALL EmisList_Pass( HcoState, TmpLct, RC )
401 : ! IF ( RC /= HCO_SUCCESS ) RETURN
402 : ! ENDIF
403 : !
404 : ! ! Advance to next container in ReadList
405 : ! TmpLct => TmpLct%NextCont
406 : ! ENDDO
407 : !
408 : ! ! Leave w/ success
409 : ! CALL HCO_LEAVE ( HcoState%Config%Err, RC )
410 : !
411 : ! END SUBROUTINE EmisList_Update
412 : !!EOC
413 : !------------------------------------------------------------------------------
414 : ! Harmonized Emissions Component (HEMCO) !
415 : !------------------------------------------------------------------------------
416 : !BOP
417 : !
418 : ! !IROUTINE: EmisList_Pass
419 : !
420 : ! !DESCRIPTION: Subroutine EmisList\_Pass passes (the ReadList)
421 : ! container Lct to EmisList. This routine mostly checks for
422 : ! additive arrays, i.e. if arrays from multiple containers have
423 : ! to be added together prior to emission calculation (e.g. sectoral
424 : ! data).
425 : !\\
426 : !\\
427 : ! !INTERFACE:
428 : !
429 0 : SUBROUTINE EmisList_Pass( HcoState, Lct, RC )
430 : !
431 : ! !USES:
432 : !
433 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
434 : USE HCO_FILEDATA_MOD, ONLY : FileData_ArrCheck
435 : !
436 : ! !INPUT PARAMETERS:
437 : !
438 : TYPE(HCO_State), POINTER :: HcoState
439 : TYPE(ListCont), POINTER :: Lct ! list container
440 : !
441 : ! !INPUT/OUTPUT PARAMETERS:
442 : !
443 : INTEGER, INTENT(INOUT) :: RC ! Success
444 : !
445 : ! !REVISION HISTORY:
446 : ! 28 Mar 2013 - C. Keller - Initial version
447 : ! See https://github.com/geoschem/hemco for complete history
448 : !EOP
449 : !------------------------------------------------------------------------------
450 : !BOC
451 : !
452 : ! !LOCAL VARIABLES:
453 : !
454 : ! Pointers
455 : TYPE(ListCont), POINTER :: TargetLct
456 :
457 : ! Scalars
458 : INTEGER :: I, J, L, T
459 : LOGICAL :: FOUND, verb, Add
460 : CHARACTER(LEN=255) :: MSG, LOC
461 :
462 : ! ================================================================
463 : ! EmisList_Pass begins here
464 : ! ================================================================
465 0 : LOC = 'EmisList_Pass (HCO_EMISLIST_MOD.F90)'
466 :
467 : ! Enter
468 0 : CALL HCO_ENTER ( HcoState%Config%Err, LOC, RC )
469 0 : IF(RC /= HCO_SUCCESS) RETURN
470 :
471 : ! Init
472 0 : TargetLct => NULL()
473 :
474 : ! Verbose mode
475 0 : verb = HCO_IsVerb( HcoState%Config%Err )
476 :
477 : ! Initialize Add flag. This fill only be set to FALSE
478 : ! if the data of the current container is added to the data of
479 : ! an existing container in EmisList instead of adding the container
480 : ! alltogether.
481 0 : Add = .TRUE.
482 :
483 : ! ----------------------------------------------------------------
484 : ! Add data arrays if required
485 : ! ----------------------------------------------------------------
486 :
487 : ! The target ID of a container denotes the ID (cID) of the
488 : ! container to which the data shall be added. For example, if
489 : ! container 1 has a target ID of 5, its content will be added to
490 : ! container 5.
491 : ! Usually, the targetID is equal to cID and we don't have to do
492 : ! anything. If tID /= cID, however, the array is added to the
493 : ! array of the specified target container and removed afterwards
494 : ! from the original container.
495 : ! Note: arrays can only be added to each other if they are for the
496 : ! same species, have same dimensions, update frequencies, scale
497 : ! factors, categories, hierarchies, data types, etc.
498 : ! Note2: in an ESMF environment, this option is disabled (targetID
499 : ! is always equal to cID).
500 0 : IF ( Lct%Dct%targetID /= Lct%Dct%cID ) THEN
501 :
502 : ! TargetLct points to the container holding the target array
503 : CALL ListCont_Find( HcoState%EmisList, Lct%Dct%targetID, &
504 0 : 0, FOUND, TargetLct )
505 0 : IF ( .NOT. FOUND ) THEN
506 : MSG = 'Cannot add emissions to target array: error in ' // &
507 0 : TRIM(Lct%Dct%cName)
508 0 : CALL HCO_ERROR( MSG, RC )
509 0 : RETURN
510 : ENDIF
511 :
512 : ! Do not add data if the current data container is not the
513 : ! 'home' container for the data object Dta. Dta may be used
514 : ! by multiple containers, and only the home container should
515 : ! modify its content!
516 0 : IF ( Lct%Dct%DtaHome /= 1 ) THEN
517 :
518 : ! Verbose mode
519 0 : IF ( verb ) THEN
520 0 : WRITE(MSG,*) 'Do not add data of ', TRIM(Lct%Dct%cName), &
521 0 : ' to ', TRIM(TargetLct%Dct%cName), ' because this', &
522 0 : ' is not the file data home container!'
523 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
524 : ENDIF
525 :
526 : ! Similarly, do not add data to target container if the target
527 : ! container is being shared by multiple containers.
528 0 : ELSEIF ( TargetLct%Dct%Dta%DoShare ) THEN
529 :
530 : ! Verbose mode
531 0 : IF ( verb ) THEN
532 0 : WRITE(MSG,*) 'Do not add data of ', TRIM(Lct%Dct%cName), &
533 0 : ' to ', TRIM(TargetLct%Dct%cName), ' because the', &
534 0 : ' target is being shared with other fields!'
535 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
536 : ENDIF
537 :
538 : ELSE
539 :
540 : ! Check extension number
541 0 : IF ( Lct%Dct%ExtNr /= TargetLct%Dct%ExtNr ) THEN
542 0 : MSG = 'Wrong ext. number: ' // TRIM(Lct%Dct%cName)
543 0 : CALL HCO_ERROR( MSG, RC )
544 0 : RETURN
545 : ENDIF
546 :
547 : ! Check data type
548 0 : IF ( Lct%Dct%DctType /= TargetLct%Dct%DctType ) THEN
549 0 : MSG = 'Wrong data type: ' // TRIM(Lct%Dct%cName)
550 0 : CALL HCO_ERROR( MSG, RC )
551 0 : RETURN
552 : ENDIF
553 :
554 : ! Check species ID
555 0 : IF ( Lct%Dct%HcoID /= TargetLct%Dct%HcoID ) THEN
556 0 : MSG = 'Wrong species ID: ' // TRIM(Lct%Dct%cName)
557 0 : CALL HCO_ERROR( MSG, RC )
558 0 : RETURN
559 : ENDIF
560 :
561 : ! Check for array dimensions
562 0 : IF ( Lct%Dct%Dta%SpaceDim /= TargetLct%Dct%Dta%SpaceDim ) THEN
563 0 : MSG = 'Wrong space dimension: ' // TRIM(Lct%Dct%cName)
564 0 : CALL HCO_ERROR( MSG, RC )
565 0 : RETURN
566 : ENDIF
567 0 : IF ( Lct%Dct%Dta%nt /= TargetLct%Dct%Dta%nt ) THEN
568 0 : MSG = 'Wrong time dim: ' // TRIM(Lct%Dct%cName)
569 0 : CALL HCO_ERROR( MSG, RC )
570 0 : RETURN
571 : ENDIF
572 0 : IF ( Lct%Dct%Dta%SpaceDim <= 2) THEN
573 0 : I = SIZE(Lct%Dct%Dta%V2(1)%Val,1)
574 0 : J = SIZE(Lct%Dct%Dta%V2(1)%Val,2)
575 : CALL FileData_ArrCheck( HcoState%Config, &
576 : TargetLct%Dct%Dta, I, J, &
577 0 : Lct%Dct%Dta%nt, RC )
578 0 : IF ( RC /= 0 ) THEN
579 0 : MSG = 'Wrong 2D array: ' // TRIM(Lct%Dct%cName)
580 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
581 0 : RETURN
582 : ENDIF
583 : ELSE
584 0 : I = SIZE(Lct%Dct%Dta%V3(1)%Val,1)
585 0 : J = SIZE(Lct%Dct%Dta%V3(1)%Val,2)
586 0 : L = SIZE(Lct%Dct%Dta%V3(1)%Val,3)
587 : CALL FileData_ArrCheck( HcoState%Config, &
588 : TargetLct%Dct%Dta, I, J, L, &
589 0 : Lct%Dct%Dta%nt, RC )
590 0 : IF ( RC /= 0 ) THEN
591 0 : MSG = 'Wrong 3D array: ' // TRIM(Lct%Dct%cName)
592 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
593 0 : RETURN
594 : ENDIF
595 : ENDIF
596 :
597 : ! Check operator
598 0 : IF ( Lct%Dct%Oper /= TargetLct%Dct%Oper ) THEN
599 0 : MSG = 'Wrong operator: ' // TRIM(Lct%Dct%cName)
600 0 : CALL HCO_ERROR( MSG, RC )
601 0 : RETURN
602 : ENDIF
603 :
604 : ! Check category
605 0 : IF ( Lct%Dct%Cat /= TargetLct%Dct%Cat ) THEN
606 0 : MSG = 'Wrong category: ' // TRIM(Lct%Dct%cName)
607 0 : CALL HCO_ERROR( MSG, RC )
608 0 : RETURN
609 : ENDIF
610 :
611 : ! Check hierarchy
612 0 : IF ( Lct%Dct%Hier /= TargetLct%Dct%Hier ) THEN
613 0 : MSG = 'Wrong hierarchy: ' // TRIM(Lct%Dct%cName)
614 0 : CALL HCO_ERROR( MSG, RC )
615 0 : RETURN
616 : ENDIF
617 :
618 : ! Error check: cannot add masks if operator is 3
619 0 : IF ( Lct%Dct%DctType == HCO_DCTTYPE_MASK .AND. &
620 : Lct%Dct%Oper == 3 ) THEN
621 : MSG = 'Cannot add masks if operator is 3: ' // &
622 0 : TRIM(Lct%Dct%cName)
623 0 : CALL HCO_ERROR( MSG, RC )
624 0 : RETURN
625 : ENDIF
626 :
627 : ! If all checks were successful, add current array to
628 : ! target array.
629 0 : DO I = 1, TargetLct%Dct%Dta%nt
630 0 : IF ( TargetLct%Dct%Dta%SpaceDim <= 2 ) THEN
631 : TargetLct%Dct%Dta%V2(I)%Val = &
632 0 : TargetLct%Dct%Dta%V2(I)%Val + Lct%Dct%Dta%V2(I)%Val
633 : ELSE
634 : TargetLct%Dct%Dta%V3(I)%Val = &
635 0 : TargetLct%Dct%Dta%V3(I)%Val + Lct%Dct%Dta%V3(I)%Val
636 : ENDIF
637 : ENDDO
638 0 : IF ( verb ) THEN
639 0 : WRITE(MSG,*) 'Added data of ', TRIM(Lct%Dct%cName), &
640 0 : ' to ', TRIM(TargetLct%Dct%cName)
641 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
642 : ENDIF
643 :
644 : ! This container does not need to be added to the emissions
645 : ! list
646 : Add = .FALSE.
647 :
648 : ENDIF
649 : ENDIF ! cID /= targetID
650 :
651 : ! ----------------------------------------------------------------
652 : ! Add/update emissions linked list container.
653 : ! Only add those containers that are effectively used in the
654 : ! emissions list, i.e. ignore the containers whose content
655 : ! has been added to another container (targetID /= cID). Those
656 : ! containers are not needed for emission calculation since its
657 : ! content is now stored in another container.
658 : ! The EmisList_Add call will set the IsInList flag of the given
659 : ! file data object (Lct%Dct%Dta) to TRUE, denoting that this file
660 : ! data object is used in EmisList. The data arrays of all file
661 : ! data objects that are not used in EmisList are removed in a
662 : ! second step of the ReadList_Read call.
663 : ! ----------------------------------------------------------------
664 : IF ( Add ) THEN
665 0 : CALL EmisList_Add( Lct%Dct, HcoState, RC )
666 0 : IF ( RC /= HCO_SUCCESS ) THEN
667 0 : CALL HCO_ERROR( 'ERROR 2', RC, THISLOC=LOC )
668 0 : RETURN
669 : ENDIF
670 : ENDIF
671 :
672 : ! ----------------------------------------------------------------
673 : ! Return
674 : ! ----------------------------------------------------------------
675 0 : CALL HCO_LEAVE( HcoState%Config%Err, RC )
676 :
677 : END SUBROUTINE EmisList_Pass
678 : !EOC
679 : !------------------------------------------------------------------------------
680 : ! Harmonized Emissions Component (HEMCO) !
681 : !------------------------------------------------------------------------------
682 : !BOP
683 : !
684 : ! !IROUTINE: HCO_GetPtr_3D
685 : !
686 : ! !DESCRIPTION: Subroutine HCO\_GetPtr\_3D returns the 3D data pointer
687 : ! Ptr3D of EmisList that is associated with data container DctName. By
688 : ! default, the routine returns an error if the given container name is
689 : ! not found. This can be avoided by calling the routine with the optional
690 : ! argument FOUND, in which case only this argument will be set to FALSE.
691 : ! Similarly, the FILLED flag can be used to control the behaviour if the
692 : ! data container is found but empty, e.g. no data is associated with it.
693 : !\\
694 : !\\
695 : ! This routine returns the unevaluated data field, e.g. no scale factors
696 : ! or masking is applied to the data. Use routine HCO\_EvalFld in
697 : ! hco\_calc\_mod.F90 to get evaluated fields.
698 : !\\
699 : !\\
700 : ! !INTERFACE:
701 : !
702 0 : SUBROUTINE HCO_GetPtr_3D( HcoState, DctName, Ptr3D, &
703 : RC, TIDX, FOUND, FILLED )
704 : !
705 : ! !USES:
706 : !
707 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
708 : !
709 : ! !INPUT PARAMETERS:
710 : !
711 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state obj
712 : CHARACTER(LEN=*), INTENT(IN ) :: DctName ! container name
713 : INTEGER, INTENT(IN), OPTIONAL :: TIDX ! time index
714 : ! ! (default=1)
715 : ! !OUTPUT PARAMETERS:
716 : !
717 : REAL(sp), POINTER :: Ptr3D(:,:,:) ! output array
718 : LOGICAL, INTENT(OUT), OPTIONAL :: FOUND ! cont. found?
719 : LOGICAL, INTENT(OUT), OPTIONAL :: FILLED ! array filled?
720 : !
721 : ! !INPUT/OUTPUT PARAMETERS:
722 : !
723 : INTEGER, INTENT(INOUT) :: RC ! Success/fail
724 : !
725 : ! !REVISION HISTORY:
726 : ! 04 Sep 2013 - C. Keller - Initial version
727 : ! See https://github.com/geoschem/hemco for complete history
728 : !EOP
729 : !------------------------------------------------------------------------------
730 : !BOC
731 : !
732 : ! !LOCAL VARIABLES:
733 : !
734 : ! Scalars
735 : INTEGER :: T
736 : LOGICAL :: FND
737 : CHARACTER(LEN=255) :: MSG, LOC
738 :
739 : ! Pointers
740 : TYPE(ListCont), POINTER :: Lct
741 :
742 : !=================================================================
743 : ! HCO_GetPtr_3D BEGINS HERE
744 : !=================================================================
745 :
746 : ! Enter
747 0 : LOC = 'HCO_GetPtr_3D (hco_emislist_mod.F90)'
748 :
749 : ! Init
750 0 : Lct => NULL()
751 :
752 : ! Define time index to use
753 0 : IF ( PRESENT(TIDX) ) THEN
754 0 : T = TIDX
755 : ELSE
756 : T = 1
757 : ENDIF
758 :
759 : ! Init
760 0 : IF ( PRESENT(FILLED) ) FILLED = .FALSE.
761 :
762 : ! Search for container in emissions linked list
763 0 : CALL ListCont_Find ( HcoState%EmisList, TRIM(DctName), FND, Lct )
764 0 : IF ( PRESENT(FOUND) ) FOUND = FND
765 :
766 : ! Check if found. If optional argument FOUND is defined, don't
767 : ! return an error if container not found but only pass the FOUND
768 : ! argument to the caller routine. Otherwise, exit with error.
769 0 : IF ( .NOT. FND ) THEN
770 0 : IF ( PRESENT(FOUND) .OR. PRESENT(FILLED) ) THEN
771 0 : Ptr3D => NULL()
772 0 : RC = HCO_SUCCESS
773 0 : RETURN
774 : ELSE
775 0 : MSG = 'Container not found: ' // TRIM(DctName)
776 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
777 0 : RETURN
778 : ENDIF
779 : ENDIF
780 :
781 : ! Check spatial dimension
782 0 : IF ( Lct%Dct%Dta%SpaceDim /= 3 ) THEN
783 0 : MSG = 'Container is not 3D: ' // TRIM(DctName)
784 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
785 0 : RETURN
786 : ENDIF
787 :
788 : ! Check time dimension
789 0 : IF ( Lct%Dct%Dta%nt < T ) THEN
790 0 : MSG = 'not enough time slices: ' // TRIM(DctName)
791 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
792 0 : RETURN
793 : ENDIF
794 :
795 0 : IF ( ASSOCIATED( Lct%Dct%Dta%V3 ) ) THEN
796 0 : Ptr3D => Lct%Dct%Dta%V3(T)%Val
797 0 : IF ( PRESENT( FILLED ) ) FILLED = .TRUE.
798 : ELSE
799 0 : IF ( PRESENT( FILLED ) ) THEN
800 0 : Ptr3D => NULL()
801 : ELSE
802 0 : MSG = 'Container data not filled: ' // TRIM(DctName)
803 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
804 0 : RETURN
805 : ENDIF
806 : ENDIF
807 :
808 : ! Leave w/ success
809 0 : RC = HCO_SUCCESS
810 :
811 : END SUBROUTINE HCO_GetPtr_3D
812 : !EOC
813 : !------------------------------------------------------------------------------
814 : ! Harmonized Emissions Component (HEMCO) !
815 : !------------------------------------------------------------------------------
816 : !BOP
817 : !
818 : ! !IROUTINE: HCO_GetPtr_2D
819 : !
820 : ! !DESCRIPTION: Subroutine HCO\_GetPtr\_2D returns the 2D data pointer
821 : ! Ptr2D of EmisList that is associated with data container DctName. See
822 : ! HCO\_GetPtr\_3D for more details.
823 : !\\
824 : !\\
825 : ! !INTERFACE:
826 : !
827 0 : SUBROUTINE HCO_GetPtr_2D( HcoState, DctName, Ptr2D, &
828 : RC, TIDX, FOUND, FILLED )
829 : !
830 : ! !USES:
831 : !
832 : USE HCO_DATACONT_MOD, ONLY : ListCont_Find
833 : !
834 : ! !INPUT PARAMETERS:
835 : !
836 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state obj
837 : CHARACTER(LEN=*), INTENT(IN ) :: DctName ! container name
838 : INTEGER, INTENT(IN), OPTIONAL :: TIDX ! time index
839 : ! ! (default=1)
840 : ! !OUTPUT PARAMETERS:
841 : !
842 : REAL(sp), POINTER :: Ptr2D(:,:) ! output array
843 : LOGICAL, INTENT(OUT), OPTIONAL :: FOUND ! cont. found?
844 : LOGICAL, INTENT(OUT), OPTIONAL :: FILLED ! array filled?
845 : !
846 : ! !INPUT/OUTPUT PARAMETERS:
847 : !
848 : INTEGER, INTENT(INOUT) :: RC ! Success/fail
849 : !
850 : ! !REVISION HISTORY:
851 : ! 04 Sep 2013 - C. Keller - Initial version
852 : ! See https://github.com/geoschem/hemco for complete history
853 : !EOP
854 : !------------------------------------------------------------------------------
855 : !BOC
856 : !
857 : ! !LOCAL VARIABLES:
858 : !
859 : ! Scalars
860 : INTEGER :: T
861 : LOGICAL :: FND
862 : CHARACTER(LEN=255) :: MSG, LOC
863 :
864 : ! Pointers
865 : TYPE(ListCont), POINTER :: Lct
866 :
867 : !=================================================================
868 : ! HCO_GetPtr_2D BEGINS HERE
869 : !=================================================================
870 :
871 : ! Enter
872 0 : LOC = 'HCO_GetPtr_2D (hco_emislist_mod.F90)'
873 0 : Lct => NULL()
874 :
875 : ! Define time index to use
876 0 : IF ( PRESENT(TIDX) )THEN
877 0 : T = TIDX
878 : ELSE
879 : T = 1
880 : ENDIF
881 :
882 : ! Init
883 0 : IF ( PRESENT(FILLED) ) FILLED = .FALSE.
884 :
885 : ! Search for container in emissions linked list
886 0 : CALL ListCont_Find( HcoState%EmisList, TRIM(DctName), FND, Lct )
887 0 : IF ( PRESENT(FOUND) ) FOUND = FND
888 :
889 : ! Check if found. If optional argument FOUND is defined, don't
890 : ! return an error if container not found but only pass the FOUND
891 : ! argument to the caller routine. Otherwise, exit with error.
892 0 : IF ( .NOT. FND ) THEN
893 0 : IF ( PRESENT(FOUND) .OR. PRESENT(FILLED) ) THEN
894 0 : Ptr2D => NULL()
895 0 : RC = HCO_SUCCESS
896 0 : RETURN
897 : ELSE
898 0 : MSG = 'Container not found: ' // TRIM(DctName)
899 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
900 0 : RETURN
901 : ENDIF
902 : ENDIF
903 :
904 : ! Check spatial dimension
905 0 : IF ( (Lct%Dct%Dta%SpaceDim/=2) .AND. &
906 : (Lct%Dct%Dta%SpaceDim/=1) ) THEN
907 0 : MSG = 'Container is not 2D: ' // TRIM(DctName)
908 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
909 0 : RETURN
910 : ENDIF
911 :
912 : ! Check time dimension
913 0 : IF ( Lct%Dct%Dta%nt < T ) THEN
914 0 : MSG = 'not enough time slices: ' // TRIM(DctName)
915 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
916 0 : RETURN
917 : ENDIF
918 :
919 0 : IF ( ASSOCIATED( Lct%Dct%Dta%V2 ) ) THEN
920 0 : Ptr2D => Lct%Dct%Dta%V2(T)%Val
921 0 : IF ( PRESENT( FILLED ) ) FILLED = .TRUE.
922 : ELSE
923 0 : IF ( PRESENT( FILLED ) ) THEN
924 0 : Ptr2D => NULL()
925 : ELSE
926 0 : MSG = 'Container data not filled: ' // TRIM(DctName)
927 0 : CALL HCO_ERROR( MSG, RC, THISLOC=LOC )
928 0 : RETURN
929 : ENDIF
930 : ENDIF
931 :
932 : ! Return w/ success
933 0 : RC = HCO_SUCCESS
934 :
935 : END SUBROUTINE HCO_GetPtr_2D
936 : !EOC
937 : END MODULE HCO_EMISLIST_MOD
|