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, DTV, KDIM, IO, S, UG, U, HPROGRAM,KLUOUT)
!!
!!    PURPOSE
!!    -------
!!  parameters defined by cover need to be extrapolated if LDATA_ISBATYPE 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_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_s_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_type_date_surf
USE modd_agri,        ONLY : lagrip
USE modd_treedrag,       ONLY : ltreedrag
!
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_ground_depth,          &
                                xdata_root_extinction, xdata_root_lin,        &
                                tdata_seed, tdata_reap, xdata_alb_veg_nir,    &
                                xdata_alb_veg_vis, xdata_alb_soil_nir,        &
                                xdata_alb_soil_vis                       
!
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) :: DTV
INTEGER, INTENT(IN) :: KDIM
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
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
!            ------------------------------
!
TYPE(date_time), DIMENSION(:,:), ALLOCATABLE :: TPWORK
REAL, DIMENSION (SIZE(XDATA_GROUND_DEPTH,1),NVEGTYPE) :: ZDATA_GROUND_DEPTH
!
 CHARACTER(LEN=3)  :: YTREE, YNAT, YVEG, YDIF, YROOT, YBAR
REAL, DIMENSION(KDIM,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'
ybar='BAR'
!
!            2. Extrapolations for land use or user
!            --------------------------------------
!
!   LAI
!   ---
IF (.NOT.any(dtv%LDATA_LAI).AND.io%CPHOTO/='NIT'.AND.io%CPHOTO/='NCB') THEN
!
  ALLOCATE(dtv%XPAR_LAI      (kdim,dtv%NTIME,nvegtype))
  DO jtime=1,36
!    
!   ECOCLIMAP spatial distribution field
    IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
    CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_lai(:,jtime,:),yveg,'ARI',s%LCOVER,kdecade=jtime)
    DO jvegtype=1,3
      WHERE (dtv%XPAR_VEGTYPE(:,jvegtype)/=0.) zwork(:,jtime,jvegtype) = 0.
    ENDDO
    !
    zdef(:) = xundef
    DO jvegtype=1,nvegtype
      IF (any(dtv%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, dtv, ug, u, &
                                   hprogram,kluout,'LAI: leaf area index',zwork(:,jtime,:),pdef=zdef)
!    
  ENDDO
!
  CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_LAI)
!
  dtv%LDATA_LAI(:)=.true.
!  
ENDIF
!
!   H_TREE
!   ------
IF (.NOT.any(dtv%LDATA_H_TREE) .AND. ((io%CPHOTO/='NON'.OR.ltreedrag) .OR. .NOT.any(dtv%LDATA_Z0))) THEN
!
  ALLOCATE(dtv%XPAR_H_TREE      (kdim,nvegtype))
  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,dtv%XPAR_H_TREE,s%XCOVER,xdata_h_tree,ytree,'ARI',s%LCOVER,kdecade=1)
!
! Extrapolation toward new vegtype distribution field from updated land-use map or user  
  CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                   hprogram,kluout,'H_TREE: height of trees',dtv%XPAR_H_TREE,pdef=zdef)
!  
  dtv%LDATA_H_TREE(:)=.true.
!  
ENDIF
!
!   DG
!   --
!
!ROOT_DEPTH is needed for DIF, 2-L, 3-L 
IF (.NOT.any(dtv%LDATA_DG) .AND. .NOT.any(dtv%LDATA_ROOT_DEPTH)) THEN
  yroot=ynat
  IF(io%CISBA=='DIF')yroot=ydif
  ALLOCATE(dtv%XPAR_ROOT_DEPTH    (kdim,nvegtype))
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)        
  CALL av_pgd(dtco,dtv%XPAR_ROOT_DEPTH(:,:),s%XCOVER,xdata_root_depth(:,:),ynat,cdgavg,s%LCOVER,kdecade=1)

  zdef(:) = xundef
  DO jvegtype=1,nvegtype
    IF (any(dtv%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(dtv%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, dtv, ug, u, &
                                   hprogram,kluout,'ROOTDEPTH', dtv%XPAR_ROOT_DEPTH(:,:),pdef=zdef)
  dtv%LDATA_ROOT_DEPTH(:) = .true.
ENDIF
!
!GROUND_DEPTH is needed for DIF and 3-L
IF (.NOT.any(dtv%LDATA_DG) .AND. io%CISBA/='2-L' .AND. .NOT.any(dtv%LDATA_GROUND_DEPTH)) THEN
  zdata_ground_depth(:,:)=xdata_ground_depth(:,:)
  IF(io%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
  ALLOCATE(dtv%XPAR_GROUND_DEPTH    (kdim,nvegtype))
  IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)      
  CALL av_pgd(dtco,dtv%XPAR_GROUND_DEPTH(:,:),s%XCOVER,zdata_ground_depth(:,:),ynat,cdgavg,s%LCOVER,kdecade=1)

  zdef(:) = xundef
  DO jvegtype=1,nvegtype
    IF (any(dtv%XPAR_VEGTYPE(:,jvegtype)/=0.) .AND. all(dtv%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, dtv, ug, u, &
                                   hprogram,kluout,'GROUNDDEPTH', dtv%XPAR_GROUND_DEPTH(:,:),pdef=zdef)
  dtv%LDATA_GROUND_DEPTH(:) = .true.
ENDIF
!
IF (io%CALBEDO=='CM13') THEN
!
  IF (.NOT.any(dtv%LDATA_ALBNIR_VEG)) THEN
    ALLOCATE(dtv%XPAR_ALBNIR_VEG(kdim,dtv%NTIME,nvegtype))
    DO jtime=1,36 
!     ECOCLIMAP spatial distribution field
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
      CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_alb_veg_nir(:,jtime,:),yveg,'ARI',s%LCOVER,kdecade=jtime)
 
!     Extrapolation toward new vegtype distribution field from updated land-use map or user 
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'ALBNIR_VEG',zwork(:,jtime,:),pdef=zdef)
    ENDDO
    CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_ALBNIR_VEG)
    dtv%LDATA_ALBNIR_VEG(:)=.true.
  ENDIF
!
  IF (.NOT.any(dtv%LDATA_ALBVIS_VEG)) THEN
    ALLOCATE(dtv%XPAR_ALBVIS_VEG(kdim,dtv%NTIME,nvegtype))
    DO jtime=1,36 
!     ECOCLIMAP spatial distribution field
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
      CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_alb_veg_vis(:,jtime,:),yveg,'ARI',s%LCOVER,kdecade=jtime)
 
!     Extrapolation toward new vegtype distribution field from updated land-use map or user 
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'ALBVIS_VEG',zwork(:,jtime,:),pdef=zdef)
    ENDDO
    CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_ALBVIS_VEG)
    dtv%LDATA_ALBVIS_VEG(:)=.true.
  ENDIF
!
  IF (.NOT.any(dtv%LDATA_ALBNIR_SOIL)) THEN
    ALLOCATE(dtv%XPAR_ALBNIR_SOIL(kdim,dtv%NTIME,nvegtype))
    DO jtime=1,36 
!     ECOCLIMAP spatial distribution field
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
      CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_alb_soil_nir(:,jtime,:),ybar,'ARI',s%LCOVER,kdecade=jtime)
 
!     Extrapolation toward new vegtype distribution field from updated land-use map or user 
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'ALBNIR_SOIL',zwork(:,jtime,:),pdef=zdef)
    ENDDO
    CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_ALBNIR_SOIL)
    dtv%LDATA_ALBNIR_SOIL(:)=.true.
  ENDIF
!
  IF (.NOT.any(dtv%LDATA_ALBVIS_SOIL)) THEN
    ALLOCATE(dtv%XPAR_ALBVIS_SOIL(kdim,dtv%NTIME,nvegtype))
    DO jtime=1,36 
!     ECOCLIMAP spatial distribution field
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
      CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_alb_soil_vis(:,jtime,:),ybar,'ARI',s%LCOVER,kdecade=jtime)
 
!     Extrapolation toward new vegtype distribution field from updated land-use map or user 
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'ALBVIS_SOIL',zwork(:,jtime,:),pdef=zdef)
    ENDDO
    CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_ALBVIS_SOIL)
    dtv%LDATA_ALBVIS_SOIL(:)=.true.
  ENDIF
!
ENDIF
!
IF(io%CPHOTO=='NIT' .OR. io%CPHOTO=='NCB') THEN
  !      
  IF (lagrip) THEN
    !
    !  IRRIG
    !  -----
    IF (.NOT.any(dtv%LDATA_IRRIG)) THEN
      zdef(:)=0.
      ALLOCATE(dtv%XPAR_IRRIG       (kdim,dtv%NTIME,nvegtype))
      DO jtime=1,36
        !   ECOCLIMAP spatial distribution field      
        IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
        CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_irrig,yveg,'ARI',s%LCOVER,kdecade=jtime)
        !   Extrapolation toward new vegtype distribution field from updated land-use map or user  
        CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                       hprogram,kluout,'IRRIG  ', zwork(:,jtime,:), pdef=zdef)
      ENDDO
      !
      CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_IRRIG)
      !
      dtv%LDATA_IRRIG(:)=.true.
      !
    ENDIF
    !
    !   WATSUP
    !   ------
    IF (.NOT.any(dtv%LDATA_WATSUP)) THEN
      zdef(:)=0.
      ALLOCATE(dtv%XPAR_WATSUP      (kdim,dtv%NTIME,nvegtype))
      DO jtime=1,36
        !   ECOCLIMAP spatial distribution field    
        IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)
        CALL av_pgd(dtco,zwork(:,jtime,:),s%XCOVER,xdata_watsup,yveg,'ARI',s%LCOVER,kdecade=jtime)  
        !   Extrapolation toward new vegtype distribution field from updated land-use map or user  
        CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                       hprogram,kluout,'WATSUP  ', zwork(:,jtime,:), pdef=zdef)
      ENDDO
      !
      CALL goto_ntime(dtv%NTIME,zwork,dtv%XPAR_WATSUP)
      !  
      dtv%LDATA_WATSUP(:)=.true.
    ENDIF
    !
    ALLOCATE(tpwork(kdim,nvegtype))
    !
    IF (.NOT.any(dtv%LDATA_SEED_M).OR..NOT.any(dtv%LDATA_SEED_D)) THEN
      ALLOCATE(dtv%XPAR_SEED_M(kdim,nvegtype))
      ALLOCATE(dtv%XPAR_SEED_D(kdim,nvegtype))
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)        
      CALL av_pgd(tpwork(:,:),s%XCOVER,tdata_seed(:,:),yveg,'MAJ',s%LCOVER,kdecade=1)
      dtv%XPAR_SEED_M(:,:) = float(tpwork(:,:)%TDATE%MONTH)
      dtv%XPAR_SEED_D(:,:) = float(tpwork(:,:)%TDATE%DAY)
      zdef(:)=5.
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'SEED_M', dtv%XPAR_SEED_M(:,:), pdef=zdef)
      zdef(:)=10.
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'SEED_D', dtv%XPAR_SEED_D(:,:), pdef=zdef)
    ENDIF
    !
    dtv%LDATA_SEED_M(:) = .true.
    dtv%LDATA_SEED_D(:) = .true.
    !    
    IF (.NOT.any(dtv%LDATA_REAP_M).OR..NOT.any(dtv%LDATA_REAP_D)) THEN
      ALLOCATE(dtv%XPAR_REAP_M(kdim,nvegtype))
      ALLOCATE(dtv%XPAR_REAP_D(kdim,nvegtype))
      IF (ASSOCIATED(dtco%XDATA_WEIGHT)) DEALLOCATE(dtco%XDATA_WEIGHT)        
      CALL av_pgd(tpwork(:,:),s%XCOVER,tdata_reap(:,:),yveg,'MAJ',s%LCOVER,kdecade=1)
      dtv%XPAR_REAP_M(:,:) = float(tpwork(:,:)%TDATE%MONTH)
      dtv%XPAR_REAP_D(:,:) = float(tpwork(:,:)%TDATE%DAY)
      zdef(:)=8.
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'REAP_M', dtv%XPAR_REAP_M(:,:), pdef=zdef)
      zdef(:)=1.
      CALL ini_var_from_vegtype_data(dtco, dtv, ug, u, &
                                     hprogram,kluout,'REAP_D', dtv%XPAR_REAP_D(:,:), pdef=zdef)
    ENDIF      
    !
    dtv%LDATA_REAP_M(:) = .true.
    dtv%LDATA_REAP_D(:) = .true.
    !    
    DEALLOCATE(tpwork)
    !
  ENDIF
  !
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