get_vegn.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 get_veg_n(HPROGRAM, KI, U, IO, S, NP, NPE, PLAI, PVH)
!     #######################################################################
!
!!****  *GET_VEG_n* - gets some veg fields on atmospheric grid
!!
!!    PURPOSE
!!    -------
!!
!!    This program returns some veg variables needed by the atmosphere
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!      P. Aumond       
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    07/2009
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t, isba_p_t, isba_pe_t, isba_np_t, isba_npe_t
!
USE modd_surf_par,         ONLY : xundef
USE modd_data_cover_par

USE modi_get_luout
USE modi_vegtype_to_patch
!                                
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
 CHARACTER(LEN=6),   INTENT(IN)   :: HPROGRAM    
INTEGER,            INTENT(IN)   :: KI         ! number of points
!
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
REAL, DIMENSION(KI), INTENT(OUT) :: PVH    ! Tree height 
REAL, DIMENSION(KI), INTENT(OUT) :: PLAI   
!-------------------------------------------------------------------------------
!
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
!  Arrays defined for each tile
!  
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
INTEGER                               :: JI,JJ           ! loop index over tiles
INTEGER                               :: ILUOUT       ! unit numberi
REAL, DIMENSION(U%NSIZE_NATURE)    :: ZH_TREE, ZLAI,ZWORK
INTEGER:: IPATCH_TRBE, IPATCH_TRBD, IPATCH_TEBE, IPATCH_TEBD, IPATCH_TENE, &
          IPATCH_BOBD, IPATCH_BONE, IPATCH_BOND, IMASK, JP
! 
!-------------------------------------------------------------------------------
!
!*   0. Logical unit for writing out
!
 CALL get_luout(hprogram,iluout)
!
!-------------------------------------------------------------------------------
!
!*       1. Passage dur le masque global
!              -------------------------------

ipatch_trbe = vegtype_to_patch(nvt_trbe, io%NPATCH)
ipatch_trbd = vegtype_to_patch(nvt_trbd, io%NPATCH)
ipatch_tebe = vegtype_to_patch(nvt_tebe, io%NPATCH)
ipatch_tebd = vegtype_to_patch(nvt_tebd, io%NPATCH)
ipatch_tene = vegtype_to_patch(nvt_tene, io%NPATCH)
ipatch_bobd = vegtype_to_patch(nvt_bobd, io%NPATCH)
ipatch_bone = vegtype_to_patch(nvt_bone, io%NPATCH)
ipatch_bond = vegtype_to_patch(nvt_bond, io%NPATCH)


zwork(:) = s%XVEGTYPE(:,nvt_trbe) + s%XVEGTYPE(:,nvt_trbd) + s%XVEGTYPE(:,nvt_tebe) + &
           s%XVEGTYPE(:,nvt_tebd) + s%XVEGTYPE(:,nvt_tene) + s%XVEGTYPE(:,nvt_bobd) + &
           s%XVEGTYPE(:,nvt_bone) + s%XVEGTYPE(:,nvt_bond)

zh_tree(:) = 0.
zlai(:) = 0.
!
DO jp = 1,io%NPATCH
  !
  IF (jp==ipatch_trbe .OR. jp==ipatch_trbd .OR. jp==ipatch_tebe .OR. jp==ipatch_tebd .OR. &
      jp==ipatch_tene .OR. jp==ipatch_bobd .OR. jp==ipatch_bone .OR. jp==ipatch_bond) THEN
    !
    pk => np%AL(jp)
    pek => npe%AL(jp)
    !
    DO jj=1,pk%NSIZE_P
      !
      imask = pk%NR_P(jj)
      !
      IF (s%XVEGTYPE(imask,jp)/=0) THEN
        !
        zh_tree(imask) = zh_tree(imask) + pk%XH_TREE(jj) * pk%XPATCH(jj)
        !
        zlai(imask)  = zlai(imask) + pek%XLAI(jj) * pk%XPATCH(jj)
        !
      ENDIF
      !
    ENDDO
    !
  ENDIF
  !
ENDDO  
!
WHERE(zwork(:)/=0.) 
  zh_tree(:) = zh_tree(:)/zwork(:)
  zlai(:) = zlai(:)/zwork(:)
END WHERE
!
zlai(:) = u%XNATURE(:) * zlai(:)
!
!*       2. Envoi les variables vers mesonH 
!             ------------------------------

IF ( SIZE(pvh) /= SIZE(zh_tree) ) THEN
  WRITE(iluout,*) 'try to get VH field from atmospheric model, but size is not correct'
  WRITE(iluout,*) 'size of field expected by the atmospheric model (PVH) :', SIZE(pvh)
  WRITE(iluout,*) 'size of field inthe surface                     (XVH) :', SIZE(zh_tree)
  CALL abor1_sfx('GET_VHN: VH SIZE NOT CORRECT')
ELSE
  pvh = zh_tree
END IF
!
!==============================================================================
!
!-------------------------------------------------------------------------------
!
IF ( SIZE(plai) /= SIZE(zlai) ) THEN
  WRITE(iluout,*) 'try to get LAI field from atmospheric model, but size is not correct'
  WRITE(iluout,*) 'size of field expected by the atmospheric model (PLAI) :', SIZE(plai)
  WRITE(iluout,*) 'size of field inthe surface                     (XLAI) :', SIZE(zlai)
  CALL abor1_sfx('GET_LAIN: LAI SIZE NOT CORRECT')
ELSE
  plai = zlai
END IF
!
!==============================================================================
!
!-------------------------------------------------------------------------------
!
!==============================================================================
!
END SUBROUTINE get_veg_n