writesurf_ch_emisn.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 writesurf_ch_emis_n (HSELECT, CHE, HPROGRAM)
!     ##########################################################
!
!!****  *WRITESURF_CH_EMIS_n* - routine to write chemistry emission fields
!!
!!    PURPOSE
!!    -------
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    03/2004
!!      M.Moge    01/2016  using WRITE_SURF_FIELD2D/3D for 2D/3D surfex fields writes
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_ch_emis_field_n, ONLY : ch_emis_field_t
!
USE modi_write_surf
USE modi_write_surf_field2d
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
!
 CHARACTER(LEN=*), DIMENSION(:), INTENT(IN) :: HSELECT
!
TYPE(ch_emis_field_t), INTENT(INOUT) :: CHE
!
 CHARACTER(LEN=6),  INTENT(IN)  :: HPROGRAM ! program calling
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
INTEGER           :: IRESP          ! IRESP  : return-code if a problem appears 
                                    ! at the open of the file in LFI  routines 
!
 CHARACTER(LEN=12) :: YRECFM         ! Name of the article to be written
 CHARACTER(LEN=100):: YCOMMENT       ! Comment string
 CHARACTER(LEN=100):: YCOMMENTUNIT   ! Comment string : unit of the datas in the field to write
 CHARACTER(LEN=80) :: YNAME          ! emitted species name
!
 CHARACTER(LEN=40),DIMENSION(CHE%NEMIS_NBR) :: YEMISPEC_NAMES
INTEGER,           DIMENSION(CHE%NEMIS_NBR) :: INBTIMES
INTEGER,           DIMENSION(CHE%NEMIS_NBR) :: IFIRST,ILAST,INEXT

INTEGER :: JI,JT          ! loop indices
INTEGER :: JSPEC          ! loop index
INTEGER :: INTIMESMAX,ITMP
INTEGER :: IEMISPEC_NBR
LOGICAL           :: GFOUND,LOK
REAL(KIND=JPRB) :: ZHOOK_HANDLE

!-------------------------------------------------------------------------------
!
!*       1.     Chemical Emission fields :
!               --------------------------
!
IF (lhook) CALL dr_hook('WRITESURF_CH_EMIS_N',0,zhook_handle)
yrecfm='EMISFILE_NBR'
ycomment='Total number of 2D emission files.'
 CALL write_surf(hselect, &
                 hprogram,yrecfm,che%NEMIS_NBR,iresp,hcomment=ycomment)
!
! count emitted species 
iemispec_nbr = 0
DO ji=1,che%NEMIS_NBR
  yname = trim(adjustl(che%CEMIS_NAME(ji)))
  gfound = .false.
  DO jspec = 1,iemispec_nbr
    IF (yemispec_names(jspec) == yname) THEN
      gfound = .true.
      EXIT
    END IF
  END DO
  IF (.NOT. gfound) THEN
    iemispec_nbr = iemispec_nbr+1
    yemispec_names(iemispec_nbr) = yname
    inbtimes(iemispec_nbr) = 1
    ifirst(iemispec_nbr) = ji
    ilast(iemispec_nbr)  = ji
    inext(ji) = 0
  ELSE
    inext(ilast(jspec)) = ji
    inext(ji)        = 0
    ilast(jspec)        = ji
    inbtimes(jspec) = inbtimes(jspec)+1
  END IF
END DO
!
yrecfm='EMISPEC_NBR '
ycomment='Number of emitted chemical species.'
 CALL write_surf(hselect, &
                 hprogram,yrecfm,iemispec_nbr,iresp,hcomment=ycomment)
!
IF (iemispec_nbr > 0) THEN
  !
  DO jspec = 1,iemispec_nbr
    CALL write_emis_spec(inbtimes(jspec))
  ENDDO
  !
ENDIF
!
IF (lhook) CALL dr_hook('WRITESURF_CH_EMIS_N',1,zhook_handle)
!
!-------------------------------------------------------------------------------
CONTAINS
!
SUBROUTINE write_emis_spec(KSIZE)
!
INTEGER, INTENT(IN) :: KSIZE
INTEGER,DIMENSION(KSIZE) :: ITIME
INTEGER,DIMENSION(KSIZE) :: IINDEX
REAL,DIMENSION(SIZE(CHE%XEMIS_FIELDS,1),KSIZE) :: ZWORK2D
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
IF (lhook) CALL dr_hook('WRITESURF_CH_EMIS_N:WRITE_EMIS_SPEC',0,zhook_handle)
!
ji = ifirst(jspec)
jt = 0
! fill the emission times array (ITIME)
! and the corresponding indices array (IINDEX)
! for species number JSPEC
DO WHILE(ji /= 0)
  jt = jt+1
  itime(jt)  = che%NEMIS_TIME(ji)
  iindex(jt) = ji
  ji = inext(ji)
END DO
IF (jt /= ksize) THEN
  CALL abor1_sfx('WRITESURF_CH_EMISN: ABNORMAL ERROR')
END IF
! sort indices according to ITIME values
lok = .true.
DO WHILE (lok)
  lok = .false.
  DO ji=2,ksize
    IF (itime(ji-1) > itime(ji)) THEN
      lok = .true.
      itmp = itime(ji-1)
      itime(ji-1) = itime(ji)
      itime(ji)   = itmp
      itmp = iindex(ji-1)
      iindex(ji-1) = iindex(ji)
      iindex(ji)   = itmp
    END IF
  END DO
END DO
! Now fill the ZWORK2D array for writing
zwork2d(:,:) = che%XEMIS_FIELDS(:,iindex(:))
! 
! Write NAME of species JSPEC with AREA and number of emission times 
! stored in the commentary
WRITE(yrecfm,'("EMISNAME",I3.3)') jspec
WRITE(ycomment,'(A3,", emission times number:",I5)') che%CEMIS_AREA(iindex(1)),ksize
 CALL write_surf(hselect, &
                 hprogram,yrecfm,yemispec_names(jspec),iresp,hcomment=ycomment)
! 
WRITE(yrecfm,'("EMISAREA",I3.3)') jspec
ycomment = "Emission area" 
 CALL write_surf(hselect, &
                 hprogram,yrecfm,che%CEMIS_AREA(iindex(1)),iresp,hcomment=ycomment)
!
WRITE(yrecfm,'("EMISNBT",I3.3)') jspec
ycomment = "Emission times number" 
 CALL write_surf(hselect, &
                 hprogram,yrecfm,ksize,iresp,hcomment=ycomment)

! Write emission times (ITIME) for species JSPEC
WRITE(yrecfm,'("EMISTIMES",I3.3)') jspec  
ycomment = "Emission times in second"
 CALL write_surf(hselect, &
                 hprogram,yrecfm,itime(:),iresp,hcomment=ycomment,hdir='-',hnam_dim="Temporal_emiss  ")
!
! Finally write emission data for species JSPEC
yrecfm = "E_"//trim(yemispec_names(jspec))
ycomment = "Emission data (x,y,t),"//trim(che%CEMIS_COMMENT(iindex(1)))
ycommentunit='-'
 CALL write_surf_field2d(hselect, &
                  hprogram,zwork2d(:,:),yrecfm,ycomment,ycommentunit,hnam_dim="Temporal_emiss  ")
!
IF (lhook) CALL dr_hook('WRITESURF_CH_EMIS_N:WRITE_EMIS_SPEC',1,zhook_handle)
!
END SUBROUTINE write_emis_spec
!
END SUBROUTINE writesurf_ch_emis_n