pgd_chemistry.F90

Go to the documentation of this file.

!SFX_LIC Copyright 1994-2014 CNRS, Meteo-France and Universite Paul Sabatier
!SFX_LIC This is part of the SURFEX software governed by the CeCILL-C licence
!SFX_LIC version 1. See LICENSE, CeCILL-C_V1-en.txt and CeCILL-C_V1-fr.txt  
!SFX_LIC for details. version 1.
!     #########
      SUBROUTINE pgd_chemistry (CHE, DTCO, UG, U, USS, &
                                hprogram,och_emis)
!     ##############################################################
!
!!**** *PGD_CHEMISTRY* monitor for averaging and interpolations of physiographic fields
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    10/12/97
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
!
!
USE modd_ch_emis_field_n, ONLY : ch_emis_field_t
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_surf_atm_sso_n, ONLY : surf_atm_sso_t
!
USE modd_pgd_grid,           ONLY : nl
USE modd_pgdwork,            ONLY : catype
USE modd_surf_par,           ONLY : xundef
USE modd_ch_surf,            ONLY : jpemismax_f
!
USE modi_get_luout
USE modi_pgd_field
USE modi_open_namelist
USE modi_close_namelist
USE modi_get_surf_size_n
USE modi_unpack_same_rank
!
USE mode_pos_surf
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_get_surf_mask_n
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(ch_emis_field_t), INTENT(INOUT) :: che
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
TYPE(surf_atm_sso_t), INTENT(INOUT) :: uss
!
 CHARACTER(LEN=6),    INTENT(IN)    :: hprogram     ! Type of program
LOGICAL,             INTENT(OUT)   :: och_emis     ! emission flag
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER                           :: iluout    ! output listing logical unit
INTEGER                           :: ilunam    ! namelist file logical unit
LOGICAL                           :: gfound    ! flag when namelist is present
INTEGER                           :: jnbr      ! loop counter on dummy fields
INTEGER                           :: ilu, il_sea, il_land, il
!
!*    0.3    Declaration of namelists
!            ------------------------
!
INTEGER                                :: nemis_pgd_nbr
 CHARACTER(LEN=40), DIMENSION(JPEMISMAX_F):: cemis_pgd_name
 CHARACTER(LEN=40), DIMENSION(JPEMISMAX_F):: cemis_pgd_comment
INTEGER,           DIMENSION(JPEMISMAX_F):: nemis_pgd_time
 CHARACTER(LEN=3),  DIMENSION(JPEMISMAX_F):: cemis_pgd_area
 CHARACTER(LEN=3),  DIMENSION(JPEMISMAX_F):: cemis_pgd_atype
 CHARACTER(LEN=28), DIMENSION(JPEMISMAX_F):: cemis_pgd_file
 CHARACTER(LEN=6),  DIMENSION(JPEMISMAX_F):: cemis_pgd_filetype
 CHARACTER(LEN=6)                       :: ymask
REAL, DIMENSION(:), ALLOCATABLE :: zemis_field, zemis_fields
INTEGER, DIMENSION(:), ALLOCATABLE :: imask
REAL(KIND=JPRB) :: zhook_handle

!
namelist/nam_ch_emis_pgd/ nemis_pgd_nbr,cemis_pgd_name,nemis_pgd_time,&
       cemis_pgd_comment,cemis_pgd_area,cemis_pgd_atype,cemis_pgd_file,&
       cemis_pgd_filetype  
!-------------------------------------------------------------------------------
!
!*    1.      Initializations of defaults
!             ---------------------------
!
!
IF (lhook) CALL dr_hook('PGD_CHEMISTRY',0,zhook_handle)
nemis_pgd_nbr = 0  
 cemis_pgd_name(:)    = '                           '
nemis_pgd_time(:)    = 0
 cemis_pgd_comment(:) = ''
 cemis_pgd_area(:)    = 'ALL'
 cemis_pgd_filetype(:)= 'DIRECT'
 cemis_pgd_file(:)    = '                           '
 cemis_pgd_atype(:)   = 'ARI'
!
 CALL get_luout(hprogram,iluout)
!
!-------------------------------------------------------------------------------
!
!*    2.      Reading of namelist
!             -------------------
!
!
 CALL open_namelist(hprogram,ilunam)
!
 CALL posnam(ilunam,'NAM_CH_EMIS_PGD',gfound,iluout)
IF (gfound) READ(unit=ilunam,nml=nam_ch_emis_pgd)
!
 CALL close_namelist(hprogram,ilunam)
!
!-------------------------------------------------------------------------------
!
!*    3.      Allocation
!             ----------
!
 che%NEMIS_NBR = nemis_pgd_nbr
!
 CALL get_surf_size_n(dtco, u, &
                      'LAND', il_land)
 CALL get_surf_size_n(dtco, u, &
                      'SEA   ',il_sea)
!
!
ALLOCATE(zemis_fields(nl))
!
ALLOCATE(che%XEMIS_FIELDS (nl,che%NEMIS_NBR))
ALLOCATE(che%CEMIS_AREA   (che%NEMIS_NBR))
ALLOCATE(che%CEMIS_COMMENT(che%NEMIS_NBR))
ALLOCATE(che%CEMIS_NAME   (che%NEMIS_NBR))
ALLOCATE(che%NEMIS_TIME   (che%NEMIS_NBR))
!
 che%CEMIS_AREA   (:) = cemis_pgd_area(1:che%NEMIS_NBR)
 che%CEMIS_NAME   (:) = cemis_pgd_name(1:che%NEMIS_NBR)
 che%NEMIS_TIME   (:) = nemis_pgd_time(1:che%NEMIS_NBR)
 che%CEMIS_COMMENT(:) = cemis_pgd_comment(1:che%NEMIS_NBR)
!
 che%NTIME_MAX = maxval(che%NEMIS_TIME)
!
!-------------------------------------------------------------------------------
och_emis = che%NEMIS_NBR > 0
!-------------------------------------------------------------------------------
!
!*    4.      Computations
!             ------------
!
DO jnbr=1,che%NEMIS_NBR
  catype = cemis_pgd_atype(jnbr)
  SELECT CASE (che%CEMIS_AREA(jnbr))
    CASE ('LAN')
      il = il_land
      ymask='LAND  '
    CASE ('SEA')
      il = il_sea
      ymask='SEA   '
    CASE ('ALL')
      il = nl
      ymask='FULL  '
    CASE default
      CALL abor1_sfx('PGD_CHEMISTRY (1): EMISSION AREA NOT SUPPORTED')
  END SELECT
  ALLOCATE(zemis_field(il))
  ALLOCATE(imask(il))
  !*    4.1     Computes the field on the surface points where it is defined
  CALL pgd_field(dtco, ug, u, uss, &
                 hprogram,che%CEMIS_NAME(jnbr),che%CEMIS_AREA(jnbr),cemis_pgd_file(jnbr), &
                   cemis_pgd_filetype(jnbr),xundef,zemis_field(:)             )  
  catype = 'ARI'
  
!*    4.2     Expends field on all surface points
  ilu=0
  CALL get_surf_mask_n(dtco, u, &
                       ymask,il,imask,ilu,iluout)
  CALL unpack_same_rank(imask,zemis_field(:),zemis_fields(:))
  DEALLOCATE(zemis_field)
  DEALLOCATE(imask)

  
!*    4.3      Weights field on all surface points 
!              (zero weight where field is not defined)
  SELECT CASE (che%CEMIS_AREA(jnbr))
    CASE ('LAN')
      che%XEMIS_FIELDS(:,jnbr) = (u%XNATURE(:)+u%XTOWN(:))*zemis_fields(:) 
    CASE ('SEA')
      che%XEMIS_FIELDS(:,jnbr) = u%XSEA*zemis_fields(:)
    CASE ('ALL')
      che%XEMIS_FIELDS(:,jnbr) = zemis_fields(:)
    CASE default
      CALL abor1_sfx('PGD_CHEMISTRY (2): EMISSION AREA NOT SUPPORTED')
  END SELECT
END DO
DEALLOCATE(zemis_fields)
IF (lhook) CALL dr_hook('PGD_CHEMISTRY',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
!*    5.      Expends 
!             ------------
!

!-------------------------------------------------------------------------------
!
END SUBROUTINE pgd_chemistry