ini_var_from_vegtype_data.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 ini_var_from_vegtype_data (DTCO, DTI, UG, U, &
                                            hprogram,iluout,hname,pfield,pdef)
!     ##############################################################
!!
!!    PURPOSE
!!    -------
!!    interpol field with n pts
!!
!!    METHOD
!!    ------ 
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    S. FAROUX        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!    Original    12/2010
!!
!----------------------------------------------------------------------------
!!*    0.     DECLARATION
!            -----------
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_data_isba_n, ONLY : data_isba_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_surf_par,        ONLY : xundef
!
USE modi_get_surf_mask_n
USE modi_interpol_field
USE modi_unpack_same_rank
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(data_isba_t), INTENT(INOUT) :: dti
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
 CHARACTER(LEN=6),             INTENT(IN)    :: hprogram  ! host model
INTEGER,                      INTENT(IN   ) :: iluout
 CHARACTER(LEN=*),             INTENT(IN   ) :: hname
REAL, DIMENSION(:,:),         INTENT(INOUT) :: pfield
REAL, DIMENSION(:), OPTIONAL, INTENT(IN   ) :: pdef 
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
REAL,    DIMENSION(:), ALLOCATABLE :: zfield_tot
INTEGER, DIMENSION(:), ALLOCATABLE :: imask  ! mask for packing from complete field to nature field
INTEGER, DIMENSION(:), ALLOCATABLE :: nsize, nsize_tot
INTEGER                            :: ini, ivegtype
INTEGER                            :: jvegtype  ! loop counter on vegtypes
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
!*    1.      Initializations
!             ---------------
!
IF (lhook) CALL dr_hook('INI_VAR_FROM_VEGTYPE_DATA',0,zhook_handle)
!
ini=SIZE(pfield,1)
ivegtype=SIZE(pfield,2)
!
ALLOCATE(imask(ini))
ALLOCATE(nsize(ini))
ALLOCATE(nsize_tot(u%NSIZE_FULL))
ALLOCATE(zfield_tot(u%NSIZE_FULL))
!
 CALL get_surf_mask_n(dtco, u, &
                      'NATURE',ini,imask,u%NSIZE_FULL,iluout)
!
DO jvegtype=1,ivegtype
  nsize(:)=0
  WHERE (pfield(:,jvegtype).NE.xundef) nsize(:)=1
  WHERE (dti%XPAR_VEGTYPE(:,jvegtype)==0.) nsize(:)=-1
  CALL unpack_same_rank(imask,nsize,nsize_tot,-1)
  CALL unpack_same_rank(imask,pfield(:,jvegtype),zfield_tot)
  IF(present(pdef))THEN
    CALL interpol_field(ug, u, &
                        hprogram,iluout,nsize_tot,zfield_tot,hname,pdef=pdef(jvegtype))
  ELSE
    CALL interpol_field(ug, u, &
                        hprogram,iluout,nsize_tot,zfield_tot,hname)
  ENDIF 
  CALL pack_same_rank(imask,zfield_tot,pfield(:,jvegtype))  
ENDDO
!
DEALLOCATE(imask)
DEALLOCATE(nsize)
DEALLOCATE(nsize_tot)
DEALLOCATE(zfield_tot)
!
IF (lhook) CALL dr_hook('INI_VAR_FROM_VEGTYPE_DATA',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE ini_var_from_vegtype_data