set_vegtypes_fractions.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 set_vegtypes_fractions (DTCO, DGU, DTI, IG, I, UG, U, &
                                         hprogram)
!     ##############################################################
!
!!**** *SET_VEGTYPES_FRACTIONS* monitor for averaging and interpolations of cover fractions
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    10/12/97
!!
!!       Modified 08/12/05, P. Le Moigne: user defined fields       
!!       Modified    07/11, R. Alkama   : 'netcdf' => 'offlin'       
!!                                        removes very small values due to computation precision
!!                   03/13, R. Alkama   : from 12 to 19 vegtypes
!!
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_diag_surf_atm_n, ONLY : diag_surf_atm_t
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_isba_grid_n, ONLY : isba_grid_t
USE modd_isba_n, ONLY : isba_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
!
USE modd_ol_fileid, ONLY : xvar_to_filein
!
USE modd_data_cover_par, ONLY : nvegtype
USE modd_surf_par,       ONLY : xundef
!
#ifdef SFX_ASC
USE modi_set_surfex_file_name_asc
#endif
#ifdef SFX_FA
USE modi_set_surfex_file_name_fa
#endif
#ifdef SFX_LFI
USE modi_set_surfex_file_name_lfi
#endif
#ifdef SFX_NC
USE modi_set_surfex_file_name_nc
#endif
!
USE modi_get_luout
USE modi_open_namelist
USE modi_close_namelist
!
USE modi_open_filein_ol
USE modi_close_filein_ol
!
USE modi_read_from_surfex_file
!
USE mode_pos_surf
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_extrapol_fields
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(diag_surf_atm_t), INTENT(INOUT) :: dgu
TYPE(data_isba_t), INTENT(INOUT) :: dti
TYPE(isba_grid_t), INTENT(INOUT) :: ig
TYPE(isba_t), INTENT(INOUT) :: i
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
!
 CHARACTER(LEN=6),    INTENT(IN)    :: hprogram     ! Type of program
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER               :: iluout    ! output listing logical unit
INTEGER               :: ilunam    ! namelist file  logical unit
LOGICAL               :: gfound    ! true if namelist is found
!
INTEGER               :: jvegtype    ! loop counter on patch
!
!*    0.3    Declaration of namelists
!            ------------------------
!
! name of files containing data
!
 CHARACTER(LEN=28)          :: cfnam_vegtype    ! fractions of each vegtypes
!
! types of file containing data
!
 CHARACTER(LEN=6)           :: cftyp_vegtype    ! fractions of each vegtypes
!
 CHARACTER(LEN=28)     :: hfilein
!
LOGICAL :: gopen
REAL(KIND=JPRB) :: zhook_handle
!
namelist/nam_land_use/cfnam_vegtype,cftyp_vegtype  

!-------------------------------------------------------------------------------
!
!*    1.      Initializations
!             ---------------
!
IF (lhook) CALL dr_hook('SET_VEGTYPES_FRACTIONS',0,zhook_handle)
 cfnam_vegtype     = '                            '
 cftyp_vegtype     = '      '
!
!-------------------------------------------------------------------------------
!
!*    2.      Input file for cover types
!             --------------------------
!
 CALL get_luout(hprogram,iluout)
 CALL open_namelist(hprogram,ilunam)
!
 CALL posnam(ilunam,'NAM_LAND_USE',gfound,iluout)
IF (gfound) READ(unit=ilunam,nml=nam_land_use)
!
 CALL close_namelist(hprogram,ilunam)
!
!-------------------------------------------------------------------------------
!
!*    3.      Uniform fields are prescribed
!             -----------------------------
!
IF(cftyp_vegtype=='NETCDF') cftyp_vegtype='OFFLIN'
!
IF (cftyp_vegtype=='ASCII ') THEN
#ifdef SFX_ASC
  CALL set_surfex_file_name_asc(hname_out=hfilein)
#endif
ELSEIF (cftyp_vegtype=='FA    ') THEN
#ifdef SFX_FA
  CALL set_surfex_file_name_fa(hname_out=hfilein)
#endif
ELSEIF (cftyp_vegtype=='LFI   ') THEN
#ifdef SFX_LFI
  CALL set_surfex_file_name_lfi(hname_out=hfilein)
#endif
ELSEIF (cftyp_vegtype=='NC    ') THEN
#ifdef SFX_NC
  CALL set_surfex_file_name_nc(hname_out=hfilein)
#endif
ENDIF
!
gopen = .false.
IF(cftyp_vegtype=='OFFLIN' .AND. .NOT.ALLOCATED(xvar_to_filein)) THEN
  gopen = .true.
  CALL open_filein_ol
ENDIF
!
IF (cftyp_vegtype=='FA    '.OR.cftyp_vegtype=='ASCII '.OR.cftyp_vegtype=='LFI   ' &
        .OR.cftyp_vegtype=='OFFLIN' .OR.cftyp_vegtype=='NC    ') THEN
!        
  dti%LDATA_VEGTYPE=.true.
!
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,1),hnam='VEGTYPE1')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,2),hnam='VEGTYPE2')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,3),hnam='VEGTYPE3')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,4),hnam='VEGTYPE4')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,5),hnam='VEGTYPE5')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,6),hnam='VEGTYPE6')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,7),hnam='VEGTYPE7')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,8),hnam='VEGTYPE8')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,9),hnam='VEGTYPE9')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,10),hnam='VEGTYPE10')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,11),hnam='VEGTYPE11')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,12),hnam='VEGTYPE12')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,13),hnam='VEGTYPE13')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,14),hnam='VEGTYPE14')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,18),hnam='VEGTYPE15')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,15),hnam='VEGTYPE16')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,16),hnam='VEGTYPE17')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,17),hnam='VEGTYPE18')
  CALL read_from_surfex_file(dtco, dgu, u, &
                             cftyp_vegtype,cfnam_vegtype,'NATURE','      ',dti%XPAR_VEGTYPE(:,19),hnam='VEGTYPE19')
!
ENDIF
!
IF (gopen) CALL close_filein_ol
!
! removes very small values due to computation precision
!
WHERE(dti%XPAR_VEGTYPE < 1.e-8)dti%XPAR_VEGTYPE(:,:)=0.0
!
IF (cftyp_vegtype=='ASCII ') THEN
#ifdef SFX_ASC
  CALL set_surfex_file_name_asc(hname_in=hfilein)
#endif
ELSEIF (cftyp_vegtype=='FA    ') THEN
#ifdef SFX_FA
  CALL set_surfex_file_name_fa(hname_in=hfilein)
#endif
ELSEIF (cftyp_vegtype=='LFI   ') THEN
#ifdef SFX_LFI
  CALL set_surfex_file_name_lfi(hname_in=hfilein)
#endif
ELSEIF (cftyp_vegtype=='NC    ') THEN
#ifdef SFX_NC
  CALL set_surfex_file_name_nc(hname_in=hfilein)
#endif
ENDIF
!
IF (dti%LDATA_VEGTYPE) THEN 
  IF (maxval(abs(sum(dti%XPAR_VEGTYPE,2)-1.))>1.e-6) THEN
    jvegtype=count(sum(dti%XPAR_VEGTYPE,2) .GT. 1.e19)
    WRITE(iluout,*) ' '
    WRITE(iluout,*) '******************************************************************************'
    WRITE(iluout,*) '* Error in ISBA data field preparation                                       *'
    WRITE(iluout,*) '* Sum of XPAR_VEGTYPE on all vegtypes is not equal to 1. for all grid point  *'
    WRITE(iluout,*) '* nbr of indef VEGTYPE =',jvegtype, ' /  total nbr =', SIZE(dti%XPAR_VEGTYPE(:,1))    
    WRITE(iluout,*) '* MAXVAL of SUM(XPAR_VEGTYPE,2) =', maxval(sum(dti%XPAR_VEGTYPE,2))
    WRITE(iluout,*) '* MAXLOC of SUM(XPAR_VEGTYPE,2) =', maxloc(sum(dti%XPAR_VEGTYPE,2))
    WRITE(iluout,*) '******************************************************************************'
    WRITE(iluout,*) ' '
    CALL abor1_sfx('SET_VEGTYPES_FRACTIONS: SUM OF ALL XPAR_VEGTYPE MUST BE 1.')
  ENDIF
ENDIF
!
IF (dti%LDATA_VEGTYPE) CALL extrapol_fields(dtco, dti, ig, i, ug, u, &
                                            hprogram,iluout)
!
IF (lhook) CALL dr_hook('SET_VEGTYPES_FRACTIONS',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE set_vegtypes_fractions