prep_hor_isba_cc_field.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 prep_hor_isba_cc_field (DTCO, U, &
                                    ig, i, &
                                   hprogram,hsurf,hatmfile,hatmfiletype,hpgdfile,hpgdfiletype)
!     #################################################################################
!
!!****  *PREP_HOR_ISBA_CC_FIELD* - reads, interpolates and prepares an ISBA-CC field
!                                   only external case implemeted
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     B. Decharme
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    05/2014
!!------------------------------------------------------------------
!
!
!
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_n, ONLY : surf_atm_t
!
USE modd_isba_grid_n, ONLY : isba_grid_t
USE modd_isba_n, ONLY : isba_t
!
USE modd_co2v_par,  ONLY : xca_nit, xcc_nit
!
USE modd_prep,      ONLY : linterp, cmask
!

USE modd_data_cover_par, ONLY : nvegtype
USE modd_surf_par,       ONLY : xundef,nundef
!
USE modi_read_prep_isba_conf
USE modi_abor1_sfx
USE modi_hor_interpol
USE modi_vegtype_grid_to_patch_grid
USE modi_get_luout
USE modi_prep_isba_cc_extern
USE modi_put_on_all_vegtypes
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(surf_atm_t), INTENT(INOUT) :: u
!
TYPE(isba_grid_t), INTENT(INOUT) :: ig
TYPE(isba_t), INTENT(INOUT) :: i
!
 CHARACTER(LEN=6),   INTENT(IN)  :: hprogram  ! program calling surf. schemes
 CHARACTER(LEN=8),   INTENT(IN)  :: hsurf     ! type of field
 CHARACTER(LEN=28),  INTENT(IN)  :: hatmfile    ! name of the Atmospheric file
 CHARACTER(LEN=6),   INTENT(IN)  :: hatmfiletype! type of the Atmospheric file
 CHARACTER(LEN=28),  INTENT(IN)  :: hpgdfile    ! name of the Atmospheric file
 CHARACTER(LEN=6),   INTENT(IN)  :: hpgdfiletype! type of the Atmospheric file
!
!*      0.2    declarations of local variables
!
 CHARACTER(LEN=6)              :: yfiletype ! type of input file
 CHARACTER(LEN=28)             :: yfile     ! name of file
 CHARACTER(LEN=6)              :: yfilepgdtype ! type of input file
 CHARACTER(LEN=28)             :: yfilepgd     ! name of file
REAL, POINTER, DIMENSION(:,:,:)     :: zfieldin  ! field to interpolate horizontally
REAL, POINTER, DIMENSION(:,:)       :: zfield    ! field to interpolate horizontally
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: zfieldoutp ! field interpolated   horizontally
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: zfieldoutv ! field interpolated   horizontally
REAL, ALLOCATABLE, DIMENSION(:,:,:) :: zw        ! work array (x, fine   soil grid, npatch)
!
INTEGER                       :: iluout    ! output listing logical unit
!
LOGICAL                       :: gunif     ! flag for prescribed uniform field
LOGICAL                       :: gprep_ags ! flag to prepare ags field (only external case implemeted)
!
INTEGER                       :: jpatch    ! loop on patches
INTEGER                       :: jvegtype  ! loop on vegtypes
INTEGER                       :: ini, inl, inp, jj, jl ! Work integer
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('PREP_HOR_ISBA_CC_FIELD',0,zhook_handle)
!
!*      1.     Reading of input file name and type
!
 CALL get_luout(hprogram,iluout)
!
 CALL read_prep_isba_conf(hprogram,hsurf,yfile,yfiletype,yfilepgd,yfilepgdtype,   &
                         hatmfile,hatmfiletype,hpgdfile,hpgdfiletype,iluout,gunif)
!
 cmask = 'NATURE'
!
ini=SIZE(ig%XLAT)
!
gprep_ags = .true.
!
!-------------------------------------------------------------------------------------
!
!*      2.     Reading of input  configuration (Grid and interpolation type)
!
IF (gunif) THEN
   gprep_ags = .false.
ELSE IF (yfiletype=='ASCLLV') THEN
   gprep_ags = .false.
ELSE IF (yfiletype=='GRIB  ') THEN
   gprep_ags = .false.
ELSE IF (yfiletype=='MESONH' .OR. yfiletype=='ASCII ' .OR. yfiletype=='LFI   '.OR.yfiletype=='FA    ') THEN
   CALL prep_isba_cc_extern(&
                            hprogram,hsurf,yfile,yfiletype,yfilepgd,yfilepgdtype,iluout,zfieldin,gprep_ags)
ELSE IF (yfiletype=='BUFFER') THEN
   gprep_ags = .false.
ELSE IF (yfiletype=='NETCDF') THEN
   gprep_ags = .false.
ELSE
   CALL abor1_sfx('PREP_HOR_ISBA_CC_FIELD: data file type not supported : '//yfiletype)
END IF
!
!-------------------------------------------------------------------------------------
!
!*      3.     Horizontal interpolation
!
IF(gprep_ags)THEN
!
  inl = SIZE(zfieldin,2)
  inp = SIZE(zfieldin,3)
!
  ALLOCATE(zfieldoutp(ini,inl,inp))
  ALLOCATE(zfield(SIZE(zfieldin,1),inl))
!
  DO jpatch = 1, inp
    zfield(:,:)=zfieldin(:,:,jpatch)
    IF (inp==nvegtype) THEN
       linterp = (i%XVEGTYPE(:,jpatch) > 0.)
    ELSEIF(inp==i%NPATCH)THEN
       linterp = (i%XPATCH(:,jpatch) > 0.)
    ENDIF
    CALL hor_interpol(dtco, u, &
                      iluout,zfield,zfieldoutp(:,:,jpatch))
    linterp = .true.
  END DO
!
  DEALLOCATE(zfield)
  DEALLOCATE(zfieldin)
!
  ALLOCATE(zfieldoutv(ini,inl,nvegtype))
!
  CALL put_on_all_vegtypes(ini,inl,inp,nvegtype,zfieldoutp,zfieldoutv)
!
  DEALLOCATE(zfieldoutp)
!
!
ENDIF
!
!-------------------------------------------------------------------------------------
!
!*      6.     Transformation from vegtype grid to patch grid
!
IF(gprep_ags)THEN
!
  ALLOCATE(zw(ini,SIZE(zfieldoutv,2),i%NPATCH))
!
  zw(:,:,:) = 0.
  CALL vegtype_grid_to_patch_grid(i%NPATCH,i%XVEGTYPE_PATCH,i%XPATCH,zfieldoutv,zw)
!
ELSE
!
  SELECT CASE (hsurf)
    !
    !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !  
    CASE('BIOMASS') 
     ALLOCATE(zw(ini,i%NNBIOMASS,i%NPATCH))
     zw(:,:,:) = 0.
     WHERE(i%XLAI(:,:)/=xundef)
       zw(:,1,:) = i%XLAI(:,:) * i%XBSLAI_NITRO(:,:)
     ENDWHERE
     zw(:,2,:) = max( 0., (zw(:,1,:)/ (xcc_nit/10.**xca_nit))  &
                          **(1.0/(1.0-xca_nit)) - zw(:,1,:) )
    !
    !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !
    CASE('LITTER') 
     ALLOCATE(zw(ini,i%NNLITTER*i%NNLITTLEVS,i%NPATCH))
     zw(:,:,:) = 0.0
    !
    !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !
    CASE('SOILCARB') 
     ALLOCATE(zw(ini,i%NNSOILCARB,i%NPATCH))
     zw(:,:,:) = 0.0
    !
    !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !
    CASE('LIGNIN') 
     ALLOCATE(zw(ini,i%NNLITTLEVS,i%NPATCH))
     zw(:,:,:) = 0.0
    !
    !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
    !
  END SELECT
!
ENDIF
!-------------------------------------------------------------------------------------
!
!*      7.     Return to historical variable
!
!
SELECT CASE (hsurf)
  !
  !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !
 CASE('BIOMASS') 
  ALLOCATE(i%XBIOMASS(ini,i%NNBIOMASS,i%NPATCH))
  inl=min(i%NNBIOMASS,SIZE(zw,2))
  DO jl=1,inl
     WHERE(zw(:,jl,:)/=xundef)
       i%XBIOMASS(:,jl,:) = zw(:,jl,:)
     ELSEWHERE
       i%XBIOMASS(:,jl,:) = 0.0
     ENDWHERE
  ENDDO
  IF(i%NNBIOMASS>inl)THEN
    DO jl=inl+1,i%NNBIOMASS
       WHERE(zw(:,jl,:)/=xundef)
         i%XBIOMASS(:,jl,:) = zw(:,inl,:)
       ELSEWHERE
         i%XBIOMASS(:,jl,:) = 0.0
       ENDWHERE
    ENDDO          
  ENDIF
  !
  !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !
 CASE('LITTER') 
  ALLOCATE(i%XLITTER(ini,i%NNLITTER,i%NNLITTLEVS,i%NPATCH))
  DO jpatch=1,i%NPATCH
    inl=0
    DO jj=1,i%NNLITTER
       DO jl=1,i%NNLITTLEVS
          inl=inl+1
          WHERE(zw(:,inl,jpatch)/=xundef)
             i%XLITTER(:,jj,jl,jpatch) = zw(:,inl,jpatch)
          ELSEWHERE
             i%XLITTER(:,jj,jl,jpatch) = 0.0
          ENDWHERE
       ENDDO
    ENDDO
  END DO
  !
  !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !
 CASE('SOILCARB') 
  ALLOCATE(i%XSOILCARB(ini,i%NNSOILCARB,i%NPATCH))
  WHERE(zw(:,:,:)/=xundef)
    i%XSOILCARB(:,:,:) = zw(:,:,:)
  ELSEWHERE
    i%XSOILCARB(:,:,:) = 0.0
  ENDWHERE
  !
  !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !
 CASE('LIGNIN') 
  ALLOCATE(i%XLIGNIN_STRUC(ini,i%NNLITTLEVS,i%NPATCH))
  WHERE(zw(:,:,:)/=xundef)
    i%XLIGNIN_STRUC(:,:,:) = zw(:,:,:)
  ELSEWHERE
    i%XLIGNIN_STRUC(:,:,:) = 0.0
  ENDWHERE
  !
  !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  !
END SELECT
!
DEALLOCATE(zw)
!-------------------------------------------------------------------------------------
!
!*      8.     Deallocations
!
IF (ALLOCATED(zfieldoutv)) DEALLOCATE(zfieldoutv)
!
IF (lhook) CALL dr_hook('PREP_HOR_ISBA_CC_FIELD',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
!
!
END SUBROUTINE prep_hor_isba_cc_field