build_pronoslistn.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 build_pronoslist_n (HSV, KEMIS_NBR,HEMIS_NAME,TPPRONOS,KCH,KLUOUT,KVERB)
!!    #######################################################################
!!
!!*** *BUILD_PRONOSLIST*
!!
!!    PURPOSE
!!    -------
!!
!!
!!**  METHOD
!!    ------
!!
!!
!!    AUTHOR
!!    ------
!!    D. Gazen
!!
!!    MODIFICATIONS
!!    -------------
!!    Original 01/02/00
!!    C. Mari  30/10/00 call to MODD_TYPE_EFUTIL
!!    D. Gazen 01/12/03 change emissions handling for surf. externalization
!!    P. Tulet 01/05/05 aerosols primary emission
!!    M.Leriche 04/2014  change length of CHARACTER for emission 6->12
!!
!!    EXTERNAL
!!    --------
!
USE modi_ch_open_inputb
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
USE modd_surfex_omp, ONLY : nblock
USE modd_type_efutil
!------------------------------------------------------------------------------
!
!*       0.   DECLARATIONS
!        -----------------
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*       0.1  declaration of arguments
!
!
 CHARACTER(LEN=*), DIMENSION(:), POINTER :: HSV
!
INTEGER,                       INTENT(IN)  :: KEMIS_NBR ! number of emitted species
 CHARACTER(LEN=12), DIMENSION(KEMIS_NBR), INTENT(IN) :: HEMIS_NAME ! name of emitted species
TYPE(pronosvar_t),             POINTER     :: TPPRONOS
INTEGER,                       INTENT(IN)  :: KCH     ! logical unit of input chemistry file
INTEGER,                       INTENT(IN)  :: KLUOUT  ! output listing channel
INTEGER,                       INTENT(IN)  :: KVERB   ! verbose level
!
!*       0.2  declaration of local variables
!
 CHARACTER(LEN=256) :: YINPLINE ! input agregation line read from Namelist
INTEGER :: INDX     ! 
INTEGER :: INBCOEFF ! Numer of agregations coeff for one species
INTEGER :: JI       ! loop index
INTEGER :: INDX_PRO ! index of the pronostic variable in CNAMES array
INTEGER :: IERR
 CHARACTER(LEN=32) :: YPRO_NAME, YEMIS_NAME ! Name of the pronostic & emission species
LOGICAL :: GFOUND
 CHARACTER(LEN=6), DIMENSION(:),POINTER :: CNAMES
TYPE(pronosvar_t),             POINTER :: HEAD,CURRENT
INTEGER :: IEQ
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!------------------------------------------------------------------------------
!
!*    EXECUTABLE STATEMENTS
!     ---------------------
!
IF (lhook) CALL dr_hook('BUILD_PRONOSLIST_N',0,zhook_handle)
!
! CNAMES points on chemical variables name
CNAMES => HSV
ieq = SIZE(hsv)
!
! Namelist is opened and the agregation eq. are reached
!
 CALL ch_open_inputb("AGREGATION", kch , kluout)
!
! Parse each eq. line and build the TPPRONOS list
!
NULLIFY(head)
NULLIFY(current)
DO 
!
! Read a line and convert 'tab' to 'space' characters
! until the keyword 'END_AGREGATION' is reached
  READ(kch,'(A)',iostat=ierr) yinpline
  IF (ierr /= 0) EXIT
  yinpline = trim(adjustl(yinpline))
  IF (len_trim(yinpline) == 0) cycle ! skip blank line
  IF (yinpline == 'END_AGREGATION') EXIT
  CALL tab2space(yinpline)
!
!
!Extract pronostic variable name
  indx = index(yinpline,' ')
  ypro_name = yinpline(1:indx-1)
!
! search the variable in CNAMES, STOP if not FOUND
  gfound = .false.
  DO ji=1,ieq
    IF (cnames(ji) == ypro_name) THEN 
      indx_pro = ji
      gfound = .true.
      EXIT
    END IF
  END DO
  IF (.NOT. gfound) THEN
    WRITE(kluout,*) 'BUILD_PRONOSLIST ERROR : ',trim(ypro_name),&
            ' not found in pronostic variables list !'  
    CALL abor1_sfx('BUILD_PRONOSLISTN: VARIABLE NOT FOUND')
  END IF
!
! If YPRO_NAME variable already encountered : append the new equation (coeffs)
  gfound = .false.
  inbcoeff = 0
  current=>head
  DO WHILE(ASSOCIATED(current))
    IF (current%NAMINDEX == indx_pro) THEN
      inbcoeff = current%NBCOEFF
      gfound   = .true.
      EXIT
    END IF
    current=>current%NEXT
  END DO
  IF (.NOT. gfound) THEN
!   New pronostic cell is created
    ALLOCATE(current)
    current%NAMINDEX = indx_pro
    current%NEXT     => head
    head => current
  END IF
!
!
! Extract the agregation coeffs
  DO
! get REAL coeff
    yinpline = adjustl(yinpline(indx:))
    indx = index(yinpline,' ')
    IF (indx == 1) EXIT
    inbcoeff = inbcoeff+1
    IF (inbcoeff > jpnbcoeffmax) THEN
      WRITE(kluout,*) 'FATAL ERROR : Number of aggregation coefficients for ',&
             trim(ypro_name),' exceeds constant JPNBCOEFFMAX = ',jpnbcoeffmax  
      WRITE(kluout,*) '=> You should increase the JPNBCOEFFMAX value in modd_type_efutil.f90'
      CALL abor1_sfx('BUILD_PRONOSLISTN: NUMBER OF AGGREGATION COEFFICIENTS TOO BIG')
    END IF
    READ(yinpline(1:indx-1),*) current%XCOEFF(inbcoeff)
!
! get EMIS species name
    yinpline = adjustl(yinpline(indx:))
    indx = index(yinpline,' ')
    yemis_name = yinpline(1:indx-1)
!
! check EMIS species name
    gfound = .false.
    DO ji=1,kemis_nbr
      IF (trim(hemis_name(ji)) == trim(yemis_name)) THEN
        gfound = .true.
        current%NEFINDEX(inbcoeff) = ji
        EXIT
      END IF
    END DO
    IF (.NOT. gfound) THEN
      WRITE(kluout,*) 'ERROR : ',trim(yemis_name),&
              ' not found in emission variables list !'  
      CALL abor1_sfx('BUILD_PRONOSLISTN: UNKNOWN EMISSION VARIABLE')
    END IF
  END DO
  current%NBCOEFF = inbcoeff
END DO
!
! Update TPPRONOS pointer with head of list
tppronos => head
!
IF (kverb >= 6) THEN
  WRITE(kluout,*) 'BUILD_PRONOSLIST: Aggregation results'
  current=>head
  DO WHILE(ASSOCIATED(current))
    WRITE(kluout,*) 'Emission for Atmospheric Chemical Species ',trim(cnames(current%NAMINDEX)),' (index ',&
            current%NAMINDEX,' in CSV)'  
    WRITE(kluout,*) 'is aggregated with the following weights from the Emission Inventory Species:'
    DO ji=1,current%NBCOEFF
      WRITE(kluout,*) current%XCOEFF(ji),hemis_name(current%NEFINDEX(ji))
    END DO
    current=>current%NEXT
  END DO
END IF
!
IF (lhook) CALL dr_hook('BUILD_PRONOSLIST_N',1,zhook_handle)
!
CONTAINS 
!!
!!    ###########################
      SUBROUTINE tab2space(HTEXT)
!!    ###########################
!!
!!*** *TAB2SPACE*
!!
!!    PURPOSE
!!    -------
!!     Convert 'tab' character to 'space' character in the string HTEXT
!!
!!**  METHOD
!!    ------
!!
!!    AUTHOR
!!    ------
!!    D. Gazen
!!
!!    MODIFICATIONS
!!    -------------
!!    Original 01/02/2000
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!------------------------------------------------------------------------------
!
!*       0.   DECLARATIONS
!        -----------------
IMPLICIT NONE
!
!*       0.1  declaration of arguments
!
 CHARACTER(len=*),INTENT(INOUT) :: HTEXT
!
!*       0.2  declaration of local variables
!
 CHARACTER, PARAMETER :: YPTAB = char(9) ! TAB character is ASCII : 9
INTEGER              :: JI
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!------------------------------------------------------------------------------
!
!*    EXECUTABLE STATEMENTS
!     ---------------------
!
IF (lhook) CALL dr_hook('TAB2SPACE',0,zhook_handle)
DO ji=1,len_trim(htext)
  IF (htext(ji:ji) == yptab) htext(ji:ji) = ' '
END DO
IF (lhook) CALL dr_hook('TAB2SPACE',1,zhook_handle)
END SUBROUTINE tab2space

END SUBROUTINE build_pronoslist_n