extrapol_fields.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 extrapol_fields (DTCO, DTI, IG, I, UG, U, &
                            hprogram,kluout)
!!
!!    PURPOSE
!!    -------
!!  parameters defined by cover need to be extrapolated if LDATA_VEGTYPE and NOT LDATA_"PARAM"
!!  all ten-day periods are calculated one time for all, then written in PGD.txt
!!
!!    METHOD
!!    ------ 
!!  these parameters are: LAI, HT, DG, ROOTFRAC, IRRIG, WATSUP
!!  Parameters are calculated as in ecoclimap, by vegtype, and then extrapolated
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    S. Faroux        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    16/11/10
!!    R. Alkama     04/12 : add 6 new tree vegtype (9 instead 3)
!!
!!    DECLARATIONS
!!
!
!
USE modd_data_cover_n, ONLY : data_cover_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_surf_par,       ONLY : xundef
!
USE modd_reprod_oper,    ONLY : cdgdif, cdgavg
!
USE modd_data_cover_par, ONLY : nvegtype, nvt_no, nvt_rock, nvt_snow, jpcover
!
USE modd_data_cover,     ONLY : xdata_lai, xdata_h_tree,                                &
                                xdata_irrig, xdata_watsup,                              &
                                xdata_garden, xdata_nature,                             &
                                xdata_root_depth, xdata_root_depthgv, xdata_ground_depth,  &
                                xdata_root_extinction, xdata_root_lin
!                                
!                                
!
USE modi_av_pgd
USE modi_ini_var_from_vegtype_data
!
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(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  ! host program
INTEGER,                INTENT(IN)    :: kluout
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
REAL, DIMENSION (SIZE(XDATA_GROUND_DEPTH,1),NVEGTYPE) :: zdata_ground_depth
!
 CHARACTER(LEN=3)  :: ytree, ynat, yveg, ydif, yroot
REAL, DIMENSION(IG%NDIM,36,NVEGTYPE) :: zwork
REAL, DIMENSION(NVEGTYPE) :: zdef
REAL :: zfrac
INTEGER :: jtime, jvegtype, jcover
!
REAL(KIND=JPRB) :: zhook_handle
!
!----------------------------------------------------------------------------
IF (lhook) CALL dr_hook('EXTRAPOL_FIELDS',0,zhook_handle)
!
ynat ='NAT'
ytree='TRE'
yveg ='VEG'
ydif ='DVG'
!
!            2. Extrapolations for land use or user
!            --------------------------------------
!
!   LAI
!   ---
IF (.NOT.dti%LDATA_LAI) THEN
!
  DO jtime=1,36
!    
!   ECOCLIMAP spatial distribution field
    IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
    CALL av_pgd(dtco, &
                zwork(:,jtime,:),i%XCOVER,xdata_lai(:,jtime,:),yveg,'ARI',i%LCOVER,kdecade=jtime)
    DO jvegtype=1,3
      WHERE (dti%XPAR_VEGTYPE(:,jvegtype)/=0.) zwork(:,jtime,jvegtype) = 0.
    ENDDO
    !
    zdef(:) = xundef
    DO jvegtype=1,nvegtype
      IF (any(dti%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(zwork(:,jtime,jvegtype)==xundef)) THEN
        zfrac = 0.
        DO jcover = 1,jpcover
          IF (dtco%XDATA_VEGTYPE(jcover,jvegtype)>zfrac) THEN
            zdef(jvegtype) = xdata_lai(jcover,jtime,jvegtype)
            zfrac = dtco%XDATA_VEGTYPE(jcover,jvegtype)
            IF (zfrac==1.) EXIT
          ENDIF
        ENDDO
      ENDIF
    ENDDO
    !    
!   Extrapolation toward new vegtype distribution field from updated land-use map or user 
    CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'LAI: leaf area index',zwork(:,jtime,:),pdef=zdef)
!    
  ENDDO
!
  CALL goto_ntime(dti%NTIME,zwork,dti%XPAR_LAI)
!
  dti%LDATA_LAI=.true.
!  
ENDIF
!
!   H_TREE
!   ------
IF (.NOT.dti%LDATA_H_TREE .AND. (i%CPHOTO/='NON' .OR. .NOT.dti%LDATA_Z0)) THEN
!
  zdef(:)=1.
  zdef(4:6)=10.
  zdef(13:17)=10.
  zdef(19)=1.
!
! ECOCLIMAP spatial distribution field  
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
  CALL av_pgd(dtco, &
                dti%XPAR_H_TREE,i%XCOVER,xdata_h_tree,ytree,'ARI',i%LCOVER,kdecade=1)
!
! Extrapolation toward new vegtype distribution field from updated land-use map or user  
  CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'H_TREE: height of trees',dti%XPAR_H_TREE,pdef=zdef)
!  
  dti%LDATA_H_TREE=.true.
!  
ENDIF
!
!   DG
!   --
!
!ROOT_DEPTH is needed for DIF, 2-L, 3-L 
IF (.NOT.dti%LDATA_DG .AND. .NOT.dti%LDATA_ROOT_DEPTH) THEN
  yroot=ynat
  IF(i%CISBA=='DIF')yroot=ydif
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)        
  CALL av_pgd(dtco, &
                dti%XPAR_ROOT_DEPTH(:,:),i%XCOVER,xdata_root_depth(:,:),ynat,cdgavg,i%LCOVER,kdecade=1)

  zdef(:) = xundef
  DO jvegtype=1,nvegtype
    IF (any(dti%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(dti%XPAR_ROOT_DEPTH(:,jvegtype)==xundef)) THEN
      zfrac = 0.
      DO jcover = 1,jpcover
        IF (dtco%XDATA_VEGTYPE(jcover,jvegtype)>zfrac) THEN
          zdef(jvegtype) = xdata_root_depth(jcover,jvegtype)
          zfrac = dtco%XDATA_VEGTYPE(jcover,jvegtype)
          IF (zfrac==1.) EXIT
        ENDIF
      ENDDO
    ENDIF
  ENDDO

  CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'ROOTDEPTH', dti%XPAR_ROOT_DEPTH(:,:),pdef=zdef)
  dti%LDATA_ROOT_DEPTH = .true.
ENDIF
!
!ROOT_DEPTH is needed for DIF, 2-L, 3-L 
IF (.NOT.dti%LDATA_DG .AND. .NOT.dti%LDATA_ROOT_DEPTHGV) THEN
  yroot=ynat
  IF(i%CISBA=='DIF')yroot=ydif
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)        
  CALL av_pgd(dtco, &
                dti%XPAR_ROOT_DEPTHGV(:,:),i%XCOVER,xdata_root_depthgv(:,:),ynat,cdgavg,i%LCOVER,kdecade=1)

  zdef(:) = xundef
  DO jvegtype=1,nvegtype
    IF (any(dti%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(dti%XPAR_ROOT_DEPTHGV(:,jvegtype)==xundef)) THEN
      zfrac = 0.
      DO jcover = 1,jpcover
        IF (dtco%XDATA_VEGTYPE(jcover,jvegtype)>zfrac) THEN
          zdef(jvegtype) = xdata_root_depthgv(jcover,jvegtype)
          zfrac = dtco%XDATA_VEGTYPE(jcover,jvegtype)
          IF (zfrac==1.) EXIT
        ENDIF
      ENDDO
    ENDIF
  ENDDO

  CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'ROOTDEPTH', dti%XPAR_ROOT_DEPTHGV(:,:),pdef=zdef)
  dti%LDATA_ROOT_DEPTHGV = .true.
ENDIF
!
!GROUND_DEPTH is needed for DIF and 3-L
IF (.NOT.dti%LDATA_DG .AND. i%CISBA/='2-L' .AND. .NOT.dti%LDATA_GROUND_DEPTH) THEN
  zdata_ground_depth(:,:)=xdata_ground_depth(:,:)
  IF(i%CISBA=='DIF'.AND.cdgdif=='ROOT')THEN
    DO jvegtype=1,nvegtype
       IF(jvegtype==nvt_no)THEN
          WHERE(xdata_ground_depth(:,jvegtype)/=xundef)
               zdata_ground_depth(:,jvegtype) = min(1.0,xdata_ground_depth(:,jvegtype))
          ENDWHERE
       ELSEIF(jvegtype/=nvt_rock.AND.jvegtype/=nvt_snow)THEN
         zdata_ground_depth(:,jvegtype) = max(1.0,xdata_root_depth(:,jvegtype))
       ELSE
         zdata_ground_depth(:,jvegtype) = xdata_root_depth(:,jvegtype)
       ENDIF
     ENDDO
  ENDIF
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)      
  CALL av_pgd(dtco, &
                dti%XPAR_GROUND_DEPTH(:,:),i%XCOVER,zdata_ground_depth(:,:),ynat,cdgavg,i%LCOVER,kdecade=1)

  zdef(:) = xundef
  DO jvegtype=1,nvegtype
    IF (any(dti%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(dti%XPAR_GROUND_DEPTH(:,jvegtype)==xundef)) THEN
      zfrac = 0.
      DO jcover = 1,jpcover
        IF (dtco%XDATA_VEGTYPE(jcover,jvegtype)>zfrac) THEN
          zdef(jvegtype) = xdata_ground_depth(jcover,jvegtype)
          zfrac = dtco%XDATA_VEGTYPE(jcover,jvegtype)
          IF (zfrac==1.) EXIT
        ENDIF
      ENDDO
    ENDIF
  ENDDO

  CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'GROUNDDEPTH', dti%XPAR_GROUND_DEPTH(:,:),pdef=zdef)
  dti%LDATA_GROUND_DEPTH = .true.
ENDIF
!
!  IRRIG
!  -----
IF (.NOT.dti%LDATA_IRRIG) THEN
   zdef(:)=0.
  DO jtime=1,36
!   ECOCLIMAP spatial distribution field      
    IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
    CALL av_pgd(dtco, &
                zwork(:,jtime,:),i%XCOVER,xdata_irrig,yveg,'ARI',i%LCOVER,kdecade=jtime)
!   Extrapolation toward new vegtype distribution field from updated land-use map or user  
    CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'IRRIG  ', zwork(:,jtime,:), pdef=zdef)
  ENDDO
!
  CALL goto_ntime(dti%NTIME,zwork,dti%XPAR_IRRIG)
!
  dti%LDATA_IRRIG=.true.
!
ENDIF
!
!   WATSUP
!   ------
IF (.NOT.dti%LDATA_WATSUP) THEN
  zdef(:)=0.
  DO jtime=1,36
!   ECOCLIMAP spatial distribution field    
    IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
    CALL av_pgd(dtco, &
                zwork(:,jtime,:),i%XCOVER,xdata_watsup,yveg,'ARI',i%LCOVER,kdecade=jtime)  
!   Extrapolation toward new vegtype distribution field from updated land-use map or user  
    CALL ini_var_from_vegtype_data(dtco, dti, ug, u, &
                                   hprogram,kluout,'WATSUP  ', zwork(:,jtime,:), pdef=zdef)
  ENDDO
  !
  CALL goto_ntime(dti%NTIME,zwork,dti%XPAR_WATSUP)
  !  
  dti%LDATA_WATSUP=.true.
ENDIF
!
IF (lhook) CALL dr_hook('EXTRAPOL_FIELDS',1,zhook_handle)
!
 CONTAINS 
!
SUBROUTINE goto_ntime(KTIME,PWORK,PPAR_DATA)
!
INTEGER, INTENT(IN) :: ktime
REAL, DIMENSION(:,:,:), INTENT(IN) :: pwork
REAL, DIMENSION(:,:,:), INTENT(OUT) :: ppar_data
!
IF (ktime==1) THEN
  ppar_data(:,1,:) = sum(pwork(:,:,:),2)/36.
ELSEIF (ktime==2) THEN
  ppar_data(:,1,:) = (sum(pwork(:,1:8,:),2) + sum(pwork(:,27:36,:),2))/18.
  ppar_data(:,2,:) = sum(pwork(:,9:26,:),2)/18.
ELSEIF (ktime==12) THEN
  DO jtime=1,12
    ppar_data(:,jtime,:) = sum(pwork(:,(jtime-1)*3+1:jtime*3,:),2)/3.
  ENDDO
ELSEIF (ktime==36) THEN
  ppar_data(:,:,:) = pwork(:,:,:)  
ENDIF
!
END SUBROUTINE goto_ntime
!
!-------------------------------------------------------------------------------
END SUBROUTINE extrapol_fields