init_veg_gardenn.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 init_veg_garden_n(KI, OCANOPY, HROUGH, TPSNOW, &
                         hphoto, plaimin, ph_tree, pvegtype, plai, pz0, pveg, pemis, &
                         otr_ml, pfaparc, pfapirc, plai_effc, pmus, &
                         palbnir_soil, palbvis_soil, palbuv_soil, palbnir, palbvis, palbuv, &
                         osurf_diag_albedo, ppsn, ppsng, ppsnv, ppsnv_a, &
                         pdir_alb, psca_alb, pemis_out, ptsrad )  
!#############################################################
!
!!****  *INIT_VEG_GARDEN_n* - routine to initialize ISBA
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_type_snow
USE modd_data_cover_par,  ONLY: nvegtype
!
USE modi_init_veg_n
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
INTEGER, INTENT(IN) :: ki
LOGICAL, INTENT(IN) :: ocanopy
 CHARACTER(LEN=4), INTENT(INOUT) :: hrough
TYPE(surf_snow),      INTENT(INOUT) :: tpsnow  ! snow characteristics
!
 CHARACTER(LEN=3), INTENT(IN) :: hphoto
REAL, DIMENSION(:), INTENT(IN) :: plaimin
REAL, DIMENSION(:), INTENT(IN) :: ph_tree
REAL, DIMENSION(:,:), INTENT(IN) :: pvegtype
REAL, DIMENSION(:), INTENT(INOUT) :: plai
REAL, DIMENSION(:), INTENT(INOUT) :: pz0
REAL, DIMENSION(:), INTENT(INOUT) :: pveg
REAL, DIMENSION(:), INTENT(INOUT) :: pemis
!
LOGICAL, INTENT(IN) :: otr_ml
REAL, DIMENSION(:), POINTER :: pfaparc
REAL, DIMENSION(:), POINTER :: pfapirc
REAL, DIMENSION(:), POINTER :: plai_effc
REAL, DIMENSION(:), POINTER :: pmus
!
REAL, DIMENSION(:), POINTER :: palbnir_soil
REAL, DIMENSION(:), POINTER :: palbvis_soil
REAL, DIMENSION(:), POINTER :: palbuv_soil
REAL, DIMENSION(:), POINTER :: palbnir
REAL, DIMENSION(:), POINTER :: palbvis
REAL, DIMENSION(:), POINTER :: palbuv
!
LOGICAL, INTENT(OUT) :: osurf_diag_albedo
!
REAL, DIMENSION(:), POINTER :: ppsn
REAL, DIMENSION(:), POINTER :: ppsng
REAL, DIMENSION(:), POINTER :: ppsnv
REAL, DIMENSION(:), POINTER :: ppsnv_a
!
REAL, DIMENSION(:,:), INTENT(OUT) :: pdir_alb
REAL, DIMENSION(:,:), INTENT(OUT) :: psca_alb
REAL, DIMENSION(:), INTENT(OUT) :: pemis_out
REAL, DIMENSION(:), INTENT(OUT) :: ptsrad
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
REAL, DIMENSION(:,:), POINTER :: zfaparc
REAL, DIMENSION(:,:), POINTER :: zfapirc
REAL, DIMENSION(:,:), POINTER :: zlai_effc
REAL, DIMENSION(:,:), POINTER :: zmus
!
REAL, DIMENSION(:,:), POINTER :: zalbnir_soil
REAL, DIMENSION(:,:), POINTER :: zalbvis_soil
REAL, DIMENSION(:,:), POINTER :: zalbuv_soil
REAL, DIMENSION(:,:), POINTER :: zalbnir
REAL, DIMENSION(:,:), POINTER :: zalbvis
REAL, DIMENSION(:,:), POINTER :: zalbuv
!
REAL, DIMENSION(:,:), POINTER :: zpsn
REAL, DIMENSION(:,:), POINTER :: zpsng
REAL, DIMENSION(:,:), POINTER :: zpsnv
REAL, DIMENSION(:,:), POINTER :: zpsnv_a
!
REAL, DIMENSION(KI,NVEGTYPE,1) :: zvegtype_patch
!
REAL, DIMENSION(SIZE(PLAIMIN),1) :: zlaimin
REAL, DIMENSION(SIZE(PH_TREE),1) :: zh_tree
REAL, DIMENSION(SIZE(PLAI),1) :: zlai
REAL, DIMENSION(SIZE(PZ0),1) :: zz0
REAL, DIMENSION(SIZE(PVEG),1) :: zveg
REAL, DIMENSION(SIZE(PEMIS),1) :: zemis
!
LOGICAL :: lagri_to_grass
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
!               Initialisation for IO
!
IF (lhook) CALL dr_hook('INIT_VEG_GARDEN_n',0,zhook_handle)
!
nullify(zfaparc)
nullify(zfapirc)
nullify(zlai_effc)
nullify(zmus)
!
nullify(zalbnir_soil)
nullify(zalbvis_soil)
nullify(zalbuv_soil)
nullify(zalbnir)
nullify(zalbvis)
nullify(zalbuv)
!
nullify(zpsn)
nullify(zpsng)
nullify(zpsnv)
nullify(zpsnv_a)
!
zlaimin(:,1) = plaimin(:)
zh_tree(:,1) = ph_tree(:)
zlai(:,1) = plai(:)
zz0(:,1) = pz0(:)
zveg(:,1) = pveg(:)
zemis(:,1) = pemis(:)
!
lagri_to_grass = .false.
!
zvegtype_patch(:,:,1) = pvegtype(:,:)
!-------------------------------------------------------------------------------
!
 CALL init_veg_n(1, ki, ocanopy, hrough, lagri_to_grass, tpsnow, &
                   hphoto, .false., .false., .false., &
                   zlaimin, zh_tree, zvegtype_patch, zlai, zz0, zveg, zemis, &
                   otr_ml, zfaparc, zfapirc, zlai_effc, zmus, &
                   zalbnir_soil, zalbvis_soil, zalbuv_soil, zalbnir, zalbvis, zalbuv, &
                   osurf_diag_albedo, zpsn, zpsng, zpsnv, zpsnv_a, &
                   pdir_alb, psca_alb, pemis, ptsrad )
!
plai(:) = zlai(:,1)
pz0(:) = zz0(:,1)
pveg(:) = zveg(:,1)
pemis(:) = zemis(:,1)
!
ALLOCATE(pfaparc(SIZE(zfaparc,1)))
IF (SIZE(zfaparc)>0) &
pfaparc(:)=zfaparc(:,1)

ALLOCATE(pfapirc(SIZE(zfapirc,1)))
IF (SIZE(zfapirc)>0) &
pfapirc(:)=zfapirc(:,1)

ALLOCATE(plai_effc(SIZE(zlai_effc,1)))
IF (SIZE(zlai_effc)>0) &
plai_effc(:)=zlai_effc(:,1)

ALLOCATE(pmus(SIZE(zmus,1)))
IF (SIZE(zmus)>0) &
pmus(:)=zmus(:,1)
!
ALLOCATE(palbnir_soil(SIZE(zalbnir_soil,1)))
palbnir_soil(:)=zalbnir_soil(:,1)
ALLOCATE(palbvis_soil(SIZE(zalbvis_soil,1)))
palbvis_soil(:)=zalbvis_soil(:,1)
ALLOCATE(palbuv_soil(SIZE(zalbuv_soil,1)))
palbuv_soil(:)=zalbuv_soil(:,1)
ALLOCATE(palbnir(SIZE(zalbnir,1)))
palbnir(:)=zalbnir(:,1)
ALLOCATE(palbvis(SIZE(zalbvis,1)))
palbvis(:)=zalbvis(:,1)
ALLOCATE(palbuv(SIZE(zalbuv,1)))
palbuv(:)=zalbuv(:,1)
!
ALLOCATE(ppsn(SIZE(zpsn,1)))
IF (SIZE(zpsn)>0) &
ppsn(:)=zpsn(:,1)

ALLOCATE(ppsng(SIZE(zpsng,1)))
IF (SIZE(zpsng)>0) &
ppsng(:)=zpsng(:,1)

ALLOCATE(ppsnv(SIZE(zpsnv,1)))
IF (SIZE(zpsnv)>0) &
ppsnv(:)=zpsnv(:,1)

ALLOCATE(ppsnv_a(SIZE(zpsnv_a,1)))
IF (SIZE(zpsnv_a)>0) &
ppsnv_a(:)=zpsnv_a(:,1)
!
IF (lhook) CALL dr_hook('INIT_VEG_GARDEN_n',1,zhook_handle)
!
END SUBROUTINE init_veg_garden_n