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, I, 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_n, ONLY : isba_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_t), INTENT(INOUT) :: i
!
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
!  
!
INTEGER                               :: ji,jj           ! loop index over tiles
INTEGER                               :: iluout       ! unit numberi
REAL, DIMENSION(U%NSIZE_FULL)      :: zh_tree_full, zlai_full
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
! 
!-------------------------------------------------------------------------------
!
!*   0. Logical unit for writing out
!
 CALL get_luout(hprogram,iluout)
!
!-------------------------------------------------------------------------------
!
!*       1. Passage dur le masque global
!              -------------------------------


zh_tree_full(:) = 0.
zlai_full(:) = xundef

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


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

DO jj=1,u%NSIZE_NATURE
  !
  IF (zwork(jj)==0) THEN
    !
    zh_tree(jj) = 0.
    zlai(jj) = 0.
    !
  ELSE
    !
    zh_tree(jj) = ( (i%XH_TREE(jj,ipatch_trbe) * i%XVEGTYPE(jj,nvt_trbe) ) + &
                    (i%XH_TREE(jj,ipatch_trbd) * i%XVEGTYPE(jj,nvt_trbd) ) + &
                    (i%XH_TREE(jj,ipatch_tebe) * i%XVEGTYPE(jj,nvt_tebe) ) + &
                    (i%XH_TREE(jj,ipatch_tebd) * i%XVEGTYPE(jj,nvt_tebd) ) + &
                    (i%XH_TREE(jj,ipatch_tene) * i%XVEGTYPE(jj,nvt_tene) ) + &
                    (i%XH_TREE(jj,ipatch_bobd) * i%XVEGTYPE(jj,nvt_bobd) ) + &
                    (i%XH_TREE(jj,ipatch_bone) * i%XVEGTYPE(jj,nvt_bone) ) + &
                    (i%XH_TREE(jj,ipatch_bond) * i%XVEGTYPE(jj,nvt_bond) ) &
                     ) / zwork(jj) 

    zlai(jj)  = ( i%XLAI(jj,ipatch_trbe) * i%XVEGTYPE(jj,nvt_trbe) ) + &
                ( i%XLAI(jj,ipatch_trbd) * i%XVEGTYPE(jj,nvt_trbd) ) + &
                ( i%XLAI(jj,ipatch_tebe) * i%XVEGTYPE(jj,nvt_tebe) ) + &
                ( i%XLAI(jj,ipatch_tebd) * i%XVEGTYPE(jj,nvt_tebd) ) + &
                ( i%XLAI(jj,ipatch_tene) * i%XVEGTYPE(jj,nvt_tene) ) + &
                ( i%XLAI(jj,ipatch_bobd) * i%XVEGTYPE(jj,nvt_bobd) ) + &
                ( i%XLAI(jj,ipatch_bone) * i%XVEGTYPE(jj,nvt_bone) )+ &
                ( i%XLAI(jj,ipatch_bond) * i%XVEGTYPE(jj,nvt_bond) )
    
    zh_tree_full(u%NR_NATURE(jj)) = zh_tree(jj)
    zlai_full(u%NR_NATURE(jj)) = zlai(jj)
    !
  END IF
  !
END DO
!
zlai_full(:) = u%XNATURE(:) * zlai_full(:)
!
!*       2. Envoi les variables vers mesonH 
!             ------------------------------

IF ( SIZE(pvh) /= SIZE(zh_tree_full) ) 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_full)
  CALL abor1_sfx('GET_VHN: VH SIZE NOT CORRECT')
ELSE
  pvh = zh_tree_full
END IF
!
!==============================================================================
!
!-------------------------------------------------------------------------------
!
IF ( SIZE(plai) /= SIZE(zlai_full) ) 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_full)
  CALL abor1_sfx('GET_LAIN: LAI SIZE NOT CORRECT')
ELSE
  plai = zlai_full
END IF
!
!==============================================================================
!
!-------------------------------------------------------------------------------
!
!==============================================================================
!
END SUBROUTINE get_veg_n