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, GCP, KLAT, IO, S, NK, NP, NPE,  &
                                   HPROGRAM,HSURF,HATMFILE,HATMFILETYPE,HPGDFILE,HPGDFILETYPE,YDCTL)
!     #################################################################################
!
!!****  *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
!!      P. Marguinaud10/2014, Support for a 2-part PREP
!!------------------------------------------------------------------
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_grid_conf_proj_n, ONLY : grid_conf_proj_t
!
USE modd_isba_options_n, ONLY : isba_options_t
USE modd_isba_n, ONLY : isba_nk_t, isba_np_t, isba_npe_t, isba_k_t, isba_s_t, &
                        isba_pe_t, isba_p_t
!
USE modd_co2v_par,  ONLY : xca_nit, xcc_nit
!
USE modd_prep,      ONLY : linterp, cmask
!
USE modd_surfex_mpi, ONLY : nrank, npio, ncomm, nproc
!
USE modd_data_cover_par, ONLY : nvegtype
USE modd_surf_par,       ONLY : xundef,nundef
!
USE mode_prep_ctl, ONLY : prep_ctl, prep_ctl_int_part2, prep_ctl_int_part4
!
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 modi_get_prep_interp
USE modi_pack_same_rank
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
#ifdef SFX_MPI
include "mpif.h"
#endif
!
!*      0.1    declarations of arguments
!
TYPE(data_cover_t), INTENT(INOUT) :: DTCO
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(grid_conf_proj_t),INTENT(INOUT) :: GCP
!
INTEGER, INTENT(IN) :: KLAT
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_s_t), INTENT(INOUT) :: S
TYPE(isba_nk_t), INTENT(INOUT) :: NK
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
type(prep_ctl),    INTENT(INOUT) :: ydctl
!
 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
!
TYPE fout
  REAL, DIMENSION(:,:), ALLOCATABLE :: ZOUT
END TYPE fout
TYPE nfout
  TYPE(fout), DIMENSION(:), ALLOCATABLE :: AL
END TYPE nfout
type(nfout) :: zw
TYPE(nfout) :: ZF
!
TYPE(isba_p_t), POINTER :: PK
TYPE(isba_pe_t), POINTER :: PEK
!
 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(:,:,:) :: ZFIELDOUTP ! field interpolated   horizontally
REAL, POINTER, DIMENSION(:,:,:) :: ZFIELDOUTV ! field interpolated   horizontally
!
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                       :: JP    ! loop on patches
INTEGER                       :: JVEGTYPE  ! loop on vegtypes
INTEGER                       :: INL, INP, JJ, JL ! Work integer
INTEGER                       :: INFOMPI
!
REAL, DIMENSION(:,:), ALLOCATABLE :: ZPATCH
!
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'
!
gprep_ags = .true.
!
!-------------------------------------------------------------------------------------
!
!*      2.     Reading of input  configuration (Grid and interpolation type)
!
NULLIFY (zfieldin, zfieldoutp, zfieldoutv)
!
IF (ydctl%LPART1) THEN
!
  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    '.OR. yfiletype=='AROME '.OR.yfiletype=='NC    ') THEN
    CALL prep_isba_cc_extern(gcp,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
!
  inl = SIZE(zfieldin,2)
  inp = SIZE(zfieldin,3)
!
ENDIF
!-------------------------------------------------------------------------------------
!
!*      3.     Horizontal interpolation
!
 CALL prep_ctl_int_part2 (ydctl, hsurf, cmask, 'NATURE', zfieldin)
!
IF (ydctl%LPART3) THEN
!
  IF(gprep_ags)THEN
    !
    IF (nrank==npio) THEN
      inl = SIZE(zfieldin,2)
      inp = SIZE(zfieldin,3)
    ELSEIF (.NOT.ASSOCIATED(zfieldin)) THEN
      ALLOCATE(zfieldin(0,0,0))
    ENDIF
    !
    IF (nproc>1) THEN
#ifdef SFX_MPI
      CALL mpi_bcast(inl,kind(inl)/4,mpi_integer,npio,ncomm,infompi)
      CALL mpi_bcast(inp,kind(inp)/4,mpi_integer,npio,ncomm,infompi)
#endif
    ENDIF
    ALLOCATE(zfieldoutp(klat,inl,inp))
  !
  ! ZPATCH is the array of output patches put on the input patches
    ALLOCATE(zpatch(klat,inp))
    zpatch(:,:) = 0.
!
    CALL get_prep_interp(inp,io%NPATCH,s%XVEGTYPE,s%XPATCH,zpatch)
  
    DO jp = 1, inp
  ! we interpolate each point the output patch is present
      linterp(:) = (zpatch(:,jp) > 0.)
      CALL hor_interpol(dtco, u, gcp, iluout,zfieldin(:,:,jp),zfieldoutp(:,:,jp))
      linterp = .true.
    END DO
!
    DEALLOCATE(zfieldin)
!
  ENDIF
  !
ENDIF
!
 CALL prep_ctl_int_part4 (ydctl, hsurf, 'NATURE', cmask, zfieldin, zfieldoutp)
!
IF (ydctl%LPART5) THEN

  ALLOCATE(zw%AL(io%NPATCH))

  IF (gprep_ags) THEN

    inl = SIZE (zfieldoutp,2)
    inp = SIZE (zfieldoutp,3)

    IF (io%NPATCH/=inp) THEN

      ALLOCATE(zfieldoutv(klat,inl,nvegtype))
      CALL put_on_all_vegtypes(klat,inl,inp,nvegtype,zfieldoutp,zfieldoutv)
!
      DEALLOCATE(zfieldoutp)
!
!-------------------------------------------------------------------------------------
!
!*      6.     Transformation from vegtype grid to patch grid
!
    !
      DO jp = 1,io%NPATCH
        pk => np%AL(jp)
        !
        ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,inl))
        !
        CALL vegtype_grid_to_patch_grid(jp,io%NPATCH,pk%XVEGTYPE_PATCH,pk%XPATCH,&
                                        pk%NR_P,zfieldoutv,zw%AL(jp)%ZOUT)
      ENDDO
      !
      DEALLOCATE(zfieldoutv)
      !
    ELSE
      !
      DO jp = 1,io%NPATCH
        !
        pk => np%AL(jp)
        !
        ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,inl))
        !
        CALL pack_same_rank(pk%NR_P,zfieldoutp(:,:,jp),zw%AL(jp)%ZOUT)
        !
      ENDDO
      !
      DEALLOCATE(zfieldoutp)
      !
    ENDIF
    !
  ELSE
    !
    DO jp = 1,io%NPATCH
      pk => np%AL(jp)
      pek => npe%AL(jp)
      !
      SELECT CASE (hsurf)
        !
        CASE('BIOMASS') 
          ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,io%NNBIOMASS))
          zw%AL(jp)%ZOUT(:,:) = 0.
          WHERE(pek%XLAI(:)/=xundef)
            zw%AL(jp)%ZOUT(:,1) = pek%XLAI(:) * pk%XBSLAI_NITRO(:)
          ENDWHERE
          zw%AL(jp)%ZOUT(:,2) = max( 0., (zw%AL(jp)%ZOUT(:,1)/ (xcc_nit/10.**xca_nit))  &
                                        **(1.0/(1.0-xca_nit)) - zw%AL(jp)%ZOUT(:,1) )
          !
        CASE('LITTER') 
          ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,io%NNLITTER*io%NNLITTLEVS))
          zw%AL(jp)%ZOUT(:,:) = 0.0
          !
        CASE('SOILCARB') 
          ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,io%NNSOILCARB))
          zw%AL(jp)%ZOUT(:,:) = 0.0
          !
        CASE('LIGNIN') 
          ALLOCATE(zw%AL(jp)%ZOUT(pk%NSIZE_P,io%NNLITTLEVS))
          zw%AL(jp)%ZOUT(:,:) = 0.0
         !
       END SELECT
       !
     ENDDO
     !
  ENDIF
!-------------------------------------------------------------------------------------
!
!*      7.     Return to historical variable
!
!
  SELECT CASE (hsurf)
    !
    CASE('BIOMASS') 
      DO jp = 1,io%NPATCH
        pek => npe%AL(jp)
        pk => np%AL(jp)

        ALLOCATE(pek%XBIOMASS(pk%NSIZE_P,io%NNBIOMASS))
        inl=min(io%NNBIOMASS,SIZE(zw%AL(jp)%ZOUT,2))
        DO jl=1,inl
          WHERE(zw%AL(jp)%ZOUT(:,jl)/=xundef)
            pek%XBIOMASS(:,jl) = zw%AL(jp)%ZOUT(:,jl)
          ELSEWHERE
            pek%XBIOMASS(:,jl) = 0.0
          ENDWHERE
        ENDDO
        IF(io%NNBIOMASS>inl)THEN
          DO jl=inl+1,io%NNBIOMASS
            WHERE(zw%AL(jp)%ZOUT(:,jl)/=xundef)
              pek%XBIOMASS(:,jl) = zw%AL(jp)%ZOUT(:,inl)
            ELSEWHERE
              pek%XBIOMASS(:,jl) = 0.0
            ENDWHERE
          ENDDO          
        ENDIF
      ENDDO
      !
    CASE('LITTER')
      DO jp = 1,io%NPATCH
        pek => npe%AL(jp)
        pk => np%AL(jp)
   
        ALLOCATE(pek%XLITTER(pk%NSIZE_P,io%NNLITTER,io%NNLITTLEVS))
        inl=0
        DO jj=1,io%NNLITTER
          DO jl=1,io%NNLITTLEVS
            inl=inl+1
            WHERE(zw%AL(jp)%ZOUT(:,inl)/=xundef)
              pek%XLITTER(:,jj,jl) = zw%AL(jp)%ZOUT(:,inl)
            ELSEWHERE
              pek%XLITTER(:,jj,jl) = 0.0
            ENDWHERE
          ENDDO
        ENDDO
      END DO
      !
    CASE('SOILCARB') 
      DO jp = 1,io%NPATCH
        pek => npe%AL(jp)
        pk => np%AL(jp)
 
        ALLOCATE(pek%XSOILCARB(pk%NSIZE_P,io%NNSOILCARB))
        WHERE(zw%AL(jp)%ZOUT(:,:)/=xundef)
          pek%XSOILCARB(:,:) = zw%AL(jp)%ZOUT(:,:)
        ELSEWHERE
          pek%XSOILCARB(:,:) = 0.0
        ENDWHERE
      ENDDO
      !
    CASE('LIGNIN') 
      DO jp = 1,io%NPATCH
        pek => npe%AL(jp)
        pk => np%AL(jp)
 
        ALLOCATE(pek%XLIGNIN_STRUC(pk%NSIZE_P,io%NNLITTLEVS))
        WHERE(zw%AL(jp)%ZOUT(:,:)/=xundef)
          pek%XLIGNIN_STRUC(:,:) = zw%AL(jp)%ZOUT(:,:)
        ELSEWHERE
          pek%XLIGNIN_STRUC(:,:) = 0.0
        ENDWHERE
      ENDDO
      !
   END SELECT
   !
   DO jp = 1,io%NPATCH
     DEALLOCATE(zw%AL(jp)%ZOUT)
   ENDDO
   DEALLOCATE(zw%AL)
   !
ENDIF
!-------------------------------------------------------------------------------------
!
!*      8.     Deallocations
!
!
IF (lhook) CALL dr_hook('PREP_HOR_ISBA_CC_FIELD',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
!-------------------------------------------------------------------------------------
!
!
END SUBROUTINE prep_hor_isba_cc_field