prep_snow_unif.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_snow_unif(KLUOUT,HSURF,PFIELD, TPTIME,  &
                          osnow_ideal,                  &
                          punif_wsnow, punif_rsnow,     &
                          punif_tsnow, punif_lwcsnow,   &
                          punif_asnow,                  &
                          punif_sg1snow, punif_sg2snow, &
                          punif_histsnow,punif_agesnow, &
                          klayer                        )  
!     #################################################################################
!
!!****  *PREP_SNOW_UNIF* - prepares snow field from prescribed values
!!
!!    PURPOSE
!!    -------
!
!!**  METHOD
!!    ------
!!
!!    REFERENCE
!!    ---------
!!      
!!
!!    AUTHOR
!!    ------
!!     V. Masson 
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      M. Lafaysse adaptation with new snow age
!!      2012-11-19 M. Lafaysse initialization of liquid water content
!!------------------------------------------------------------------
!
USE mode_snow3l
!
USE modd_type_date_surf, ONLY : date_time
!
USE modd_surf_par,       ONLY : xundef
USE modd_prep,           ONLY : cinterp_type
USE modd_prep_snow,      ONLY : ngrid_level
USE modd_data_cover_par, ONLY : nvegtype
!
USE modi_snow_t_wliq_to_heat
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*      0.1    declarations of arguments
!
INTEGER,            INTENT(IN)  :: kluout    ! output listing logical unit
 CHARACTER(LEN=10),  INTENT(IN)  :: hsurf     ! type of field
REAL, POINTER, DIMENSION(:,:,:) :: pfield    ! field to interpolate horizontally
TYPE(date_time),    INTENT(IN)  :: tptime    ! date and time
LOGICAL,            INTENT(IN)  :: osnow_ideal
REAL, DIMENSION(:), INTENT(IN)  :: punif_wsnow ! prescribed snow content (kg/m2)
REAL, DIMENSION(:), INTENT(IN)  :: punif_rsnow ! prescribed density (kg/m3)
REAL, DIMENSION(:), INTENT(IN)  :: punif_tsnow ! prescribed temperature (K)
REAL, DIMENSION(:), INTENT(IN)  :: punif_lwcsnow ! prescribed snow liquid water content (kg/m3)
REAL,               INTENT(IN)  :: punif_asnow ! prescribed albedo (-)
REAL, DIMENSION(:), INTENT(IN)  :: punif_sg1snow ! 
REAL, DIMENSION(:), INTENT(IN)  :: punif_sg2snow ! 
REAL, DIMENSION(:), INTENT(IN)  :: punif_histsnow ! 
REAL, DIMENSION(:), INTENT(IN)  :: punif_agesnow ! 
INTEGER,            INTENT(IN)  :: klayer        ! Number of layer of output snow scheme
!
!*      0.2    declarations of local variables
!
REAL, DIMENSION(:,:,:), ALLOCATABLE :: ztsnow, zrsnow
REAL, DIMENSION(:,:,:), ALLOCATABLE :: zlwcsnow !(kg/m2)
!
REAL, DIMENSION(1) :: zd
INTEGER            :: jvegtype       ! loop counter on vegtypes
!
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------------
!
!
IF (lhook) CALL dr_hook('PREP_SNOW_UNIF',0,zhook_handle)
!
IF (osnow_ideal) THEN
  ALLOCATE(pfield(1,SIZE(punif_wsnow),nvegtype))
  ALLOCATE(ztsnow(1,SIZE(punif_wsnow),nvegtype))
  ALLOCATE(zrsnow(1,SIZE(punif_wsnow),nvegtype))
  ALLOCATE(zlwcsnow(1,SIZE(punif_wsnow),nvegtype))
ELSE
  IF(hsurf(1:3)=='DEP')THEN
    ALLOCATE(pfield(1,klayer,nvegtype))
  ELSE
    ALLOCATE(pfield(1,ngrid_level,nvegtype))
  ENDIF
  ALLOCATE(ztsnow(1,ngrid_level,nvegtype))
  ALLOCATE(zrsnow(1,ngrid_level,nvegtype))
  ALLOCATE(zlwcsnow(1,ngrid_level,nvegtype))
ENDIF
!
!*      1.     No snow
!              -------
!
IF (any(punif_rsnow(:)==0. .AND. punif_wsnow(:)/=0.)) THEN 
  WRITE(kluout,*)'XWSNOW/=0. AND RSNOW=0.'
  CALL abor1_sfx('PREP_SNOW_UNIF: WITH XWSNOW/=0., RSNOW MUST NOT BE 0.')
END IF
!
!*      2.     Snow prescribed
!              ---------------
!
SELECT CASE(hsurf(1:3))
!
  CASE('WWW')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_wsnow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_wsnow(1)
       ENDDO
    ENDIF
!    
  CASE('DEP')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_wsnow(:)/punif_rsnow(:)
       ENDDO
    ELSE
       IF(punif_rsnow(1)>0.0)THEN
         zd(1)=punif_wsnow(1)/punif_rsnow(1)
       ELSE
         zd(1)=0.0
       ENDIF
       DO jvegtype=1,nvegtype
          CALL snow3lgrid(pfield(:,:,jvegtype),zd(:))
       ENDDO
    ENDIF
!
  CASE('RHO')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_rsnow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_rsnow(1)
       ENDDO
    ENDIF
!
  CASE('ALB')
    DO jvegtype=1,nvegtype
       pfield(1,:,jvegtype) = punif_asnow
    ENDDO
!
  CASE('HEA')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          zrsnow(1,:,jvegtype) = punif_rsnow(:)
          ztsnow(1,:,jvegtype) = punif_tsnow(:)
         zlwcsnow(1,:,jvegtype) = punif_lwcsnow(:) ! kg/m3
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          zrsnow(1,:,jvegtype) = punif_rsnow(1)
          ztsnow(1,:,jvegtype) = punif_tsnow(1)
          zlwcsnow(1,:,jvegtype) = punif_lwcsnow(1) ! kg/m3
       ENDDO
    ENDIF
    CALL snow_t_wliq_to_heat(pfield,zrsnow,ztsnow,zlwcsnow)
!
  CASE('SG1')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_sg1snow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_sg1snow(1)
       ENDDO
    ENDIF
!
  CASE('SG2')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_sg2snow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_sg2snow(1)
       ENDDO
    ENDIF
!
  CASE('HIS')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_histsnow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_histsnow(1)
       ENDDO
    ENDIF    
!
  CASE('AGE')
    IF (osnow_ideal) THEN
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_agesnow(:)
       ENDDO
    ELSE
       DO jvegtype=1,nvegtype
          pfield(1,:,jvegtype) = punif_agesnow(1)
       ENDDO
    ENDIF           
  !
END SELECT
!
!*      2.     Interpolation method
!              --------------------
!
 cinterp_type='UNIF  '
DEALLOCATE(ztsnow)
DEALLOCATE(zrsnow)
DEALLOCATE(zlwcsnow)
IF (lhook) CALL dr_hook('PREP_SNOW_UNIF',1,zhook_handle)
!
!-------------------------------------------------------------------------------------
END SUBROUTINE prep_snow_unif