init_isba_landuse.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 init_isba_landuse (DTCO, UG, U, IO, NK, NP, NPE, PMESH_SIZE, HPROGRAM)  
!#############################################################
!
!!****  *INIT_ISBA_LANDUSE* - routine to initialize land use for ISBA field
!!
!!    PURPOSE
!!    -------
!     Extrapolation from existing surounding cells with same patch properties:
!!      (1) IPTS=n  interpol field with n pts
!!      (2) IPTS=0  conserve cells mass  
!!   Case 2 : simple extrapolation based on the inside cell informations.
!!             this is donne before conserving cell or global mass
!!
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      B. Decharme   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    07/2011
!!
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_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_p_t, isba_pe_t
!
USE modd_type_snow
USE modd_surf_par,ONLY : xundef                 
!
USE modd_surfex_mpi, ONLY : nproc, ncomm
!
USE modi_get_luout
USE modi_ini_var_from_patch
USE modi_conserv_global_mass
!
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_grid_t), INTENT(INOUT) :: UG
TYPE(surf_atm_t), INTENT(INOUT) :: U
TYPE(isba_options_t), INTENT(INOUT) :: IO
TYPE(isba_nk_t), INTENT(INOUT) :: NK
TYPE(isba_np_t), INTENT(INOUT) :: NP
TYPE(isba_npe_t), INTENT(INOUT) :: NPE
!
REAL, DIMENSION(:), INTENT(IN) :: PMESH_SIZE
!
 CHARACTER(LEN=6),                 INTENT(IN)  :: HPROGRAM  ! program calling surf. schemes
!
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
TYPE(isba_pe_t), POINTER :: PEK
TYPE(isba_p_t), POINTER :: PK
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZZDG     ! Actual layer thicknesses
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZZDG_OLD ! Old layer thicknesses
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWG_OLD  ! Old XWG
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ZWGI_OLD ! Old XWGI
!
INTEGER, DIMENSION(IO%NPATCH,0:NPROC-1) :: ICOUNT_ALL
INTEGER, DIMENSION(IO%NPATCH) :: ICOUNT
INTEGER :: ILUOUT, ISIZE, JP, ICPT
INTEGER :: JLAYER, JNBIOMASS, JNLITTER, JNLITTLEVS, JNSOILCARB
#ifdef SFX_MPI
INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ISTATUS
#endif
INTEGER :: INFOMPI
REAL(KIND=JPRB) :: ZHOOK_HANDLE
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('INIT_ISBA_LANDUSE',0,zhook_handle)
 CALL get_luout(hprogram,iluout)
!
!-------------------------------------------------------------------------------
!
icount(:) = 0
DO jp=1,io%NPATCH
  pk => np%AL(jp)
  IF (pk%NSIZE_P==0) THEN
    icount(jp) = 1
  ELSEIF(all(pk%XDG(:,io%NGROUND_LAYER)==pk%XDG_OLD(:,io%NGROUND_LAYER))) THEN
    icount(jp) = 1
  ENDIF
ENDDO
!
IF (nproc>1) THEN
#ifdef SFX_MPI
  CALL mpi_allgather(icount,SIZE(icount)*kind(icount)/4,mpi_integer,&
                     icount_all,kind(icount_all)/4,mpi_integer,ncomm,infompi)
#endif
ELSE
  icount_all(:,0) = icount
ENDIF
!
icpt = 0
DO jp = 1,io%NPATCH
  ! all the values are the same
  IF (all(icount_all(jp,:)/=0)) icpt = icpt + 1
ENDDO
!
IF ( icpt==io%NPATCH ) THEN
  IF (lhook) CALL dr_hook('INIT_ISBA_LANDUSE',1,zhook_handle)
  RETURN
ENDIF
!
!-------------------------------------------------------------------------------
! Conserve mass in the cell
!-------------------------------------------------------------------------------
!
 CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'WR      ', 0)

IF (io%LGLACIER) &
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH, hprogram,iluout,'ICE_STO ', 0)
!
DO jlayer=1,SIZE(npe%AL(1)%XTG,2)
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH, hprogram,iluout,'TEMP GRO', 0, jlayer)
END DO
!
!
 CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH, hprogram,iluout,'ALBSNOW ', 0)
!
IF (npe%AL(1)%TSNOW%SCHEME=='1-L'  .OR. npe%AL(1)%TSNOW%SCHEME=='3-L' .OR. npe%AL(1)%TSNOW%SCHEME=='CRO') THEN
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'EMISSNOW', 0)    
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'TSSNOW  ', 0)
ENDIF
!
DO jlayer=1,npe%AL(1)%TSNOW%NLAYER
  !
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'WSNOW   ', 0, jlayer)
  !
  IF (npe%AL(1)%TSNOW%SCHEME=='3-L' .OR. npe%AL(1)%TSNOW%SCHEME=='CRO') THEN            
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'TEMPSNOW',0, jlayer)
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'HEATSNOW', 0, jlayer)     
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'AGESNOW ', 0, jlayer)
  ENDIF
  !
  IF (npe%AL(1)%TSNOW%SCHEME=='1-L') THEN
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'TSNOW   ', 0, jlayer)
  ENDIF
  !
  IF(npe%AL(1)%TSNOW%SCHEME=='CRO') THEN
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'GR1SNOW', 0, jlayer)
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'GR2SNOW', 0, jlayer)
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'HISTSNOW', 0, jlayer)
  ENDIF
  !
ENDDO
!
!-------------------------------------------------------------------------------
! Conserve mass globaly because soil depth change
!-------------------------------------------------------------------------------
!
ALLOCATE(zzdg(SIZE(np%AL(1)%XDG,1),SIZE(np%AL(1)%XDG,2),io%NPATCH))
ALLOCATE(zzdg_old(SIZE(np%AL(1)%XDG,1),SIZE(np%AL(1)%XDG,2),io%NPATCH))
ALLOCATE(zwg_old(SIZE(np%AL(1)%XDG,1),SIZE(np%AL(1)%XDG,2),io%NPATCH))
ALLOCATE(zwgi_old(SIZE(np%AL(1)%XDG,1),SIZE(np%AL(1)%XDG,2),io%NPATCH))
!
DO jp = 1,io%NPATCH
  pek => npe%AL(jp)
  pk => np%AL(jp)

  isize = np%AL(jp)%NSIZE_P
  zwg_old(1:isize,:,jp) =pek%XWG   (:,:)
  zwgi_old(1:isize,:,jp) =pek%XWGI  (:,:)
  zzdg(1:isize,1,jp) =pk%XDG    (:,1)
  zzdg_old(1:isize,1,jp) =pk%XDG_OLD(:,1)
  IF(io%CISBA=='DIF')THEN
    DO jlayer=2,io%NGROUND_LAYER
      zzdg(1:isize,jlayer,jp) = pk%XDG    (:,jlayer)-pk%XDG    (:,jlayer-1)
      zzdg_old(1:isize,jlayer,jp) = pk%XDG_OLD(:,jlayer)-pk%XDG_OLD(:,jlayer-1)
    ENDDO
  ELSE     
    zzdg(:,2,jp) = pk%XDG    (:,2)
    zzdg_old(:,2,jp) = pk%XDG_OLD(:,2)
    IF(io%CISBA=='3-L' )THEN
      zzdg(:,3,jp) = pk%XDG    (:,3)-pk%XDG    (:,2)
      zzdg_old(:,3,jp) = pk%XDG_OLD(:,3)-pk%XDG_OLD(:,2)
    ENDIF 
  ENDIF
ENDDO
!
WHERE(zzdg(:,:,:)    >1.e+10)zzdg(:,:,:)=0.
WHERE(zzdg_old(:,:,:)>1.e+10)zzdg_old(:,:,:)=0.
!
DO jlayer=1,io%NGROUND_LAYER
   CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'WG      ', 0, jlayer)
   CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'WGI     ', 0, jlayer)
ENDDO
!
!
 CALL conserv_global_mass(dtco, u, np, npe, pmesh_size, io%NPATCH,iluout,zzdg,zzdg_old,'WG ',zwg_old)
 CALL conserv_global_mass(dtco, u, np, npe, pmesh_size,io%NPATCH,iluout,zzdg,zzdg_old,'WGI',zwgi_old)
!
DEALLOCATE(zwg_old,zzdg,zzdg_old,zwgi_old)
!
!-------------------------------------------------------------------------------
! Extrapolation with 3 pts 
!-------------------------------------------------------------------------------
!
 CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'RESA    ', 3, jlayer)
!
DO jlayer=1,npe%AL(1)%TSNOW%NLAYER
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'RHOSNOW ', 3, jlayer)
ENDDO
!
IF (io%CPHOTO/='NON') THEN
  !
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'AN      ', 3)
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'ANDAY   ', 3)   
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'ANFM    ', 3)
  CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'LE      ', 3)
  !
  DO jnbiomass=1,io%NNBIOMASS
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'RESPBIOM', 3,jnbiomass)
    CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'BIOMASS ', 3,jnbiomass)
 ENDDO
 !
 IF (io%CRESPSL=='CNT') THEN
   !
   DO jnlittlevs=1,io%NNLITTLEVS
     CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'LIGNINST',3,jnlittlevs)
     DO jnlitter=1,io%NNLITTER
       CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'LITTER  ',3,jnlitter,jnlittlevs)
     ENDDO
   ENDDO
   !
   DO jnsoilcarb=1,io%NNSOILCARB
     CALL ini_var_from_patch(dtco, ug, u, np, npe, io%NPATCH,hprogram,iluout,'SOILCARB',3,jnsoilcarb)
   ENDDO
   !
 ENDIF
 !
ENDIF
!
!-------------------------------------------------------------------------------
!  
IF (lhook) CALL dr_hook('INIT_ISBA_LANDUSE',1,zhook_handle)
!
END SUBROUTINE init_isba_landuse