read_prep_garden_snow.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 read_prep_garden_snow(HPROGRAM,HSNOW,KSNOW_LAYER,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,OUNIF)
!     #######################################################
!
!!****  *READ_PREP_GARDEN_SNOW* - routine to read the configuration for snow
!!                              in ISBA fields preparation
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004 
!!     A. Bogatchev 09/2005 EBA snow option
!!     V. Vionnet   06/2008 - Flag for snow metamorphism
!                           - Preparation of uniform snow fields : density, temperture,albedo,grain types
!!                          - Flag to avtivate new maximal liquid water holding capacity : formulation used by Crocus
!!     M. Lafaysse  08/2013 init XZSNOW or XLWCSNOW
!      B. Decharme  07/2013 Add ES snow grid case : 6-L or 12-L
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modn_prep_garden_snow
USE modd_read_namelist, ONLY : lnam_read
!
USE modd_surf_par,       ONLY : xundef
USE modd_snow_par,   ONLY : xansmin, xrhosmax
USE modd_csts,       ONLY : xtt
!
USE mode_pos_surf
USE modi_test_nam_var_surf
USE modi_get_luout
USE modi_open_namelist
USE modi_close_namelist
USE modi_abor1_sfx
!
USE modd_prep_teb_garden, ONLY : cfile_snow_gd, ctype_snow, cfilepgd_snow_gd, &
                                 ctypepgd_snow, lsnow_ideal_gd, &
                                 xwsnow_p=>xwsnow_gd, xtsnow_p=>xtsnow_gd, xlwcsnow_p=>xlwcsnow_gd, &
                                 xrsnow_p=>xrsnow_gd, xagesnow_p=>xagesnow_gd, xasnow_gd
!
USE modd_prep_snow, ONLY : nsnow_layer_max, lsnow_prep_perm
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
 CHARACTER(LEN=6),  INTENT(IN)  :: hprogram ! program calling ISBA
 CHARACTER(LEN=3),  INTENT(OUT) :: hsnow    ! snow scheme
INTEGER, INTENT(OUT)           :: ksnow_layer  ! number of snow layers
 CHARACTER(LEN=28), OPTIONAL, INTENT(OUT) :: hfile        ! file name
 CHARACTER(LEN=6),  OPTIONAL, INTENT(OUT) :: hfiletype    ! file type
 CHARACTER(LEN=28),OPTIONAL, INTENT(OUT) :: hfilepgd     ! file name
 CHARACTER(LEN=6), OPTIONAL, INTENT(OUT) :: hfilepgdtype ! file type 
 LOGICAL,          OPTIONAL, INTENT(OUT) :: ounif        ! uniform snow
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
 CHARACTER(LEN=3) :: csnow
INTEGER :: nsnow_layer
 CHARACTER(LEN=28) :: cfile_snow, cfilepgd_snow
LOGICAL :: lsnow_ideal, lsnow_frac_tot, lswemax
REAL :: xasnow, xswemax
REAL, DIMENSION(NSNOW_LAYER_MAX) :: xwsnow, xzsnow, xrsnow, xtsnow, xlwcsnow, xsg1snow, xsg2snow,&
                                    xhistsnow, xagesnow
INTEGER           :: jlayer
!
REAL, DIMENSION(NSNOW_LAYER_MAX) :: xwsnow_gd, xzsnow_gd, xrsnow_gd, xtsnow_gd, xlwcsnow_gd, &
                                    xsg1snow_gd, xsg2snow_gd, xhistsnow_gd, xagesnow_gd
!
LOGICAL           :: lfile
!
LOGICAL           :: gfound         ! Return code when searching namelist
INTEGER           :: iluout         ! output file logical unit
INTEGER           :: ilunam         ! namelist file logical unit
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
namelist/nam_prep_isba_snow/csnow, nsnow_layer, cfile_snow, ctype_snow, &
                            cfilepgd_snow, ctypepgd_snow,               & 
                            lsnow_ideal, lsnow_frac_tot, lsnow_prep_perm,       &
                            xwsnow, xzsnow, xtsnow, xlwcsnow, xrsnow, xasnow,  &
                            xsg1snow, xsg2snow, xhistsnow, xagesnow,    &
                            lswemax,xswemax
namelist/nam_prep_garden_snow/csnow_gd, nsnow_layer_gd, cfile_snow_gd, ctype_snow, &
                              cfilepgd_snow_gd, ctypepgd_snow,               & 
                              lsnow_ideal_gd, xwsnow_gd, xzsnow_gd, xtsnow_gd, xlwcsnow_gd, xrsnow_gd, xasnow_gd
!-------------------------------------------------------------------------------
!* default
!  -------
!

IF (lhook) CALL dr_hook('READ_PREP_GARDEN_SNOW',0,zhook_handle)
IF (lnam_read) THEN
  !  
  csnow_gd = 'D95'
  nsnow_layer_gd = 1
  !
  cfile_snow_gd    = '                         '
  ctype_snow    = '      '  
  cfilepgd_snow_gd    = '                         '
  ctypepgd_snow    = '      '    
  !
  lsnow_ideal_gd = .false.
  lsnow_prep_perm = .true.
  !
  xwsnow_gd(:) = 0.
  xzsnow_gd(:) = xundef
  xrsnow_gd(:) = xrhosmax
  xtsnow_gd(:) = xtt
  xlwcsnow_gd(:) = 0.
  xasnow_gd = xansmin  
  xsg1snow_gd(:) = xundef
  xsg2snow(:) = xundef
  xhistsnow_gd(:) = xundef
  xagesnow_gd(:) = xundef
  !
  lswemax=.false.
  xswemax=500.
  !
  CALL get_luout(hprogram,iluout)
  CALL open_namelist(hprogram,ilunam)
  !
  !* reading of namelist
  !  -------------------
  !
  !* default can be provided by ISBA scheme variables
  CALL posnam(ilunam,'NAM_PREP_ISBA_SNOW',gfound,iluout)
  IF (gfound) THEN
    !
    csnow = 'D95'
    nsnow_layer = 1
    cfile_snow = '                         '
    cfilepgd_snow = '                         '
    lsnow_ideal = .false.
    lsnow_frac_tot = .false.
    xwsnow(:) = xundef
    xzsnow(:) = xundef
    xrsnow(:) = xrhosmax
    xtsnow(:) = xtt
    xasnow = xansmin  
    xsg1snow(:) = xundef
    xsg2snow(:) = xundef
    xhistsnow(:) = xundef
    xagesnow(:) = xundef 
    xlwcsnow(:) = 0. 
    !       
    READ(unit=ilunam,nml=nam_prep_isba_snow)
    CALL test_nam_var_surf(iluout,'CSNOW',csnow,'D95','3-L','EBA','NON','CRO')
    !
    csnow_gd = csnow
    nsnow_layer_gd = nsnow_layer
    cfile_snow_gd = cfile_snow
    cfilepgd_snow_gd = cfilepgd_snow
    lsnow_ideal_gd = lsnow_ideal
    xwsnow_gd(:) = xwsnow(:)
    xzsnow_gd(:) = xzsnow(:)    
    xrsnow_gd(:) = xrsnow(:)
    xtsnow_gd(:) = xtsnow(:)
    xlwcsnow_gd(:) = xlwcsnow(:)    
    xasnow_gd = xasnow
    xsg1snow_gd(:) = xsg1snow(:)
    xsg2snow_gd(:) = xsg2snow(:)
    xhistsnow_gd(:) = xhistsnow(:)
    xagesnow_gd(:) = xagesnow(:)
    !
  ENDIF
  !
  !* It is erased by GARDEN namelist if specified
  CALL posnam(ilunam,'NAM_PREP_GARDEN_SNOW',gfound,iluout)
  IF (gfound) THEN
    READ(unit=ilunam,nml=nam_prep_garden_snow)
    !crocus can't be used in garden if not used in isba scheme
    CALL test_nam_var_surf(iluout,'CSNOW',csnow_gd,'D95','3-L','EBA','NON')
  ENDIF
  !
  IF (csnow_gd=='NON') nsnow_layer_gd = 0
  !
  IF (csnow_gd=='D95' .OR. csnow_gd=='EBA') nsnow_layer_gd = 1
  ! not more than 3 layers for snow in garden
  IF (csnow_gd=='3-L' .AND. nsnow_layer_gd<=2) nsnow_layer_gd = 12
  !
  IF (nsnow_layer_gd > nsnow_layer_max) THEN
    WRITE(iluout,*) '------------------------------------'
    WRITE(iluout,*) 'Please update modd_prep_snow.f90 routine : '
    WRITE(iluout,*) 'The maximum number of snow layers  '
    WRITE(iluout,*) 'in the declaration of the namelist variables '
    WRITE(iluout,*) 'must be decreased to : ', nsnow_layer_max
    WRITE(iluout,*) '------------------------------------'
    CALL abor1_sfx('READ_PREP_GARDEN_SNOW: NUMBER OF SNOW LAYERS MUST BE INCREASED IN NAMELIST DECLARATION')
  ENDIF
  !
  ALLOCATE(xwsnow_p(nsnow_layer_gd))
  ALLOCATE(xrsnow_p(nsnow_layer_gd))
  ALLOCATE(xtsnow_p(nsnow_layer_gd))
  ALLOCATE(xagesnow_p(nsnow_layer_gd))
  ALLOCATE(xlwcsnow_p(nsnow_layer_gd))
  !
  DO jlayer=1,nsnow_layer_gd
  
    IF ((xzsnow_gd(jlayer)>0) .AND.(xzsnow_gd(jlayer)/=xundef )) THEN
      IF ((xwsnow_gd(jlayer)>0)  .AND.(xwsnow_gd(jlayer)/=xundef )) THEN    
        WRITE(iluout,*) 'XWSNOW and XZSNOW are both defined.'
        WRITE(iluout,*) 'You must define only one of them.'
        WRITE(iluout,*) '    PLEASE CORRECT THAT     '
        CALL abor1_sfx('READ_PREP_GARDEN_SNOW: ERROR IN INITIALIZATION OF SNOW DEPTH')
      ELSE
        xwsnow_p(jlayer)=xzsnow_gd(jlayer)*xrsnow_gd(jlayer)
      ENDIF
    ELSE
      xwsnow_p(jlayer)=xwsnow_gd(jlayer)
    ENDIF
  ENDDO

  xrsnow_p=xrsnow_gd(1:nsnow_layer_gd)
  xtsnow_p=xtsnow_gd(1:nsnow_layer_gd)
  xagesnow_p=xagesnow_gd(1:nsnow_layer_gd)
  xlwcsnow_p=xlwcsnow_gd(1:nsnow_layer_gd)
  !
  CALL close_namelist(hprogram,ilunam)
  !
ENDIF
!
hsnow = csnow_gd
!
ksnow_layer = nsnow_layer_gd
!
IF(all(xwsnow_p(:)==xundef).AND.present(ounif))THEN
    ounif=.false.
ELSEIF(present(ounif))THEN
    ounif=.true.
ENDIF
!
lfile=(len_trim(cfile_snow_gd)>0.AND.len_trim(ctype_snow)>0 &
       .AND.len_trim(cfilepgd_snow_gd)>0.AND.len_trim(ctypepgd_snow)>0)
!
IF (present(ounif)) lfile=(lfile .AND. .NOT.ounif)
!
IF(present(hfile))THEN 
  IF(lfile)THEN
     hfile = cfile_snow_gd
  ELSE
     hfile = '                         '
  ENDIF
ENDIF
IF(present(hfiletype))THEN 
  IF(lfile)THEN
     hfiletype = ctype_snow
  ELSE
     hfiletype = '      '
  ENDIF
ENDIF
IF(present(hfilepgdtype))THEN 
  IF(lfile)THEN
     hfilepgdtype = ctypepgd_snow
  ELSE
     hfilepgdtype = '      '
  ENDIF
ENDIF
IF(present(hfilepgd))THEN 
  IF(lfile)THEN
     hfilepgd = cfilepgd_snow_gd
  ELSE
     hfilepgd = '                         '
  ENDIF
ENDIF
IF (lfile.AND.present(ounif)) ounif=.false.
!
IF (lhook) CALL dr_hook('READ_PREP_GARDEN_SNOW',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
END SUBROUTINE read_prep_garden_snow