read_prep_isba_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_isba_snow(HPROGRAM,HSNOW,KSNOW_LAYER,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,OUNIF)
!     #######################################################
!
!!****  *READ_PREP_ISBA_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
!!     B. Decharme  07/2012 Bug init uniform snow
!!      M. Lafaysse 11/2012, snow liquid water content
!!      M. Lafaysse 11/2012, possibility to prescribe snow depth instead of snow water equivalent
!!      M Lafaysse 04/2014 : LSNOW_PREP_PERM
!      B. Decharme  07/2013 ES snow grid layer can be > to 3 (default 12)
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modn_prep_isba_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_isba, ONLY : cfile_snow, ctype_snow, cfilepgd_snow, &
                           ctypepgd_snow, lsnow_ideal, &
                           xwsnow_p=>xwsnow, xtsnow_p=>xtsnow,  &
                           xlwcsnow_p=>xlwcsnow, &
                           xrsnow_p=>xrsnow, xasnow,            &
                           xsg1snow_p=>xsg1snow, xsg2snow_p=>xsg2snow, &
                           xhistsnow_p=>xhistsnow, xagesnow_p=>xagesnow
                           
!
USE modd_prep_snow, ONLY : lsnow_frac_tot, 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
!              -------------------------------
!
REAL, DIMENSION(NSNOW_LAYER_MAX) :: xwsnow, xzsnow, xrsnow, xtsnow, xlwcsnow, &
                                    xsg1snow, xsg2snow, xhistsnow, xagesnow
INTEGER           :: jlayer
!
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
!-------------------------------------------------------------------------------
!* default
!  -------
!
IF (lhook) CALL dr_hook('READ_PREP_ISBA_SNOW',0,zhook_handle)
IF (lnam_read) THEN
  !
  csnow = 'D95'
  nsnow_layer = 1
  !
  cfile_snow = '                         '
  ctype_snow = '      '
  cfilepgd_snow = '                         '
  ctypepgd_snow = '      '  
  !
  lsnow_ideal = .false.
  lsnow_frac_tot = .false.
  lsnow_prep_perm = .true.
  !
  xwsnow(:) = xundef
  xzsnow(:) = xundef
  xrsnow(:) = xundef  
  xtsnow(:) = xtt  
  xlwcsnow(:) = 0.
  xasnow = xansmin
  xsg1snow(:) = xundef
  xsg2snow(:) = xundef
  xhistsnow(:) = xundef
  xagesnow(:) = xundef  
  !
  lswemax=.false. 
  xswemax=500. 
  !
  CALL get_luout(hprogram,iluout)
  CALL open_namelist(hprogram,ilunam)
  !
  !* reading of namelist
  !  -------------------
  !
  CALL posnam(ilunam,'NAM_PREP_ISBA_SNOW',gfound,iluout)
  IF (gfound) READ(unit=ilunam,nml=nam_prep_isba_snow)
  !
  CALL test_nam_var_surf(iluout,'CSNOW',csnow,'D95','3-L','EBA','CRO','NON')
  !
  IF (csnow=='NON') nsnow_layer = 0
  !
  IF (csnow=='D95' .OR. csnow=='EBA') nsnow_layer = 1
  !
  IF ((csnow=='3-L' .OR. csnow=='CRO') .AND. nsnow_layer<=2) nsnow_layer = 12
  !
  IF (nsnow_layer > 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_ISBA_SNOW: NUMBER OF SNOW LAYERS MUST BE INCREASED IN NAMELIST DECLARATION')
  ENDIF
  !
  ! Convert prescribed snow depth and snow density in snow water equivalent
  DO jlayer=1,nsnow_layer
    IF (xzsnow(jlayer)/=xundef) THEN
      IF (xwsnow(jlayer)/=xundef) THEN
        WRITE(iluout,*) '----------------------------'
        WRITE(iluout,*) 'layer ',jlayer,':'
        WRITE(iluout,*) 'XWSNOW and XZSNOW are both defined.'
        WRITE(iluout,*) 'You must define only one of them.'
        WRITE(iluout,*) '    PLEASE CORRECT THAT     '
        WRITE(iluout,*) '----------------------------'
        CALL abor1_sfx('READ_PREP_ISBA_SNOW: ERROR IN INITIALISATION OF SNOW PARAMETERS')
      ELSEIF (xrsnow(jlayer)==xundef) THEN
        WRITE(iluout,*) '----------------------------'
        WRITE(iluout,*) 'layer ',jlayer,':'
        WRITE(iluout,*) 'XZSNOW is defined           '
        WRITE(iluout,*) 'but XRSNOW is not.          '
        WRITE(iluout,*) '    PLEASE CORRECT THAT     '
        WRITE(iluout,*) '----------------------------'
        CALL abor1_sfx('READ_PREP_ISBA_SNOW: ERROR IN INITIALISATION OF SNOW PARAMETERS')
      ELSE
        xwsnow(jlayer)=xzsnow(jlayer)*xrsnow(jlayer)
      END IF
    ENDIF
  END DO

  IF(nsnow_layer>=3)THEN
    IF(xwsnow(1)/=xundef.AND.any(xwsnow(2:nsnow_layer)==xundef))THEN
      WHERE(xwsnow(2:nsnow_layer)==xundef)xwsnow(2:nsnow_layer)=0.0
    ENDIF
    IF(xrsnow(1)/=xundef.AND.any(xrsnow(2:nsnow_layer)==xundef))THEN
      WHERE(xrsnow(2:nsnow_layer)==xundef)xrsnow(2:nsnow_layer)=xrsnow(1)
    ENDIF    
  ENDIF
  !
  ALLOCATE(xwsnow_p(nsnow_layer))
  ALLOCATE(xrsnow_p(nsnow_layer))
  ALLOCATE(xtsnow_p(nsnow_layer))
  ALLOCATE(xlwcsnow_p(nsnow_layer))
  ALLOCATE(xagesnow_p(nsnow_layer))
  !
  xwsnow_p  =xwsnow(1:nsnow_layer)
  xrsnow_p  =xrsnow(1:nsnow_layer)
  xtsnow_p  =xtsnow(1:nsnow_layer)
  xagesnow_p=xagesnow(1:nsnow_layer)
  xlwcsnow_p=xlwcsnow(1:nsnow_layer)
  !

  !Coherence test between XTSNOW and XLWCSNOW
  DO jlayer=1,nsnow_layer
    IF  ((xlwcsnow_p(jlayer)>0.).AND.(xtsnow_p(jlayer)<xtt)) THEN
        WRITE(iluout,*) '----------------------------'
        WRITE(iluout,*) 'layer ',jlayer,':'
        WRITE(iluout,*) 'Incoherence between         '
        WRITE(iluout,*) 'snow liquid water content   '
        WRITE(iluout,*) 'and snow temperature.       '
        WRITE(iluout,*) '    PLEASE CORRECT THAT     '
        WRITE(iluout,*) '----------------------------'
        CALL abor1_sfx('READ_PREP_ISBA_SNOW: ERROR IN INITIALISATION OF SNOW PARAMETERS')
    END IF
  END DO

  IF (csnow=='CRO') THEN
    !
    ALLOCATE(xsg1snow_p(nsnow_layer))
    ALLOCATE(xsg2snow_p(nsnow_layer))
    ALLOCATE(xhistsnow_p(nsnow_layer))
    !
    xsg1snow_p =xsg1snow(1:nsnow_layer)
    xsg2snow_p =xsg2snow(1:nsnow_layer)
    xhistsnow_p=xhistsnow(1:nsnow_layer)
    !
    DO jlayer=1,nsnow_layer
      IF ((xsg1snow_p(jlayer)==xundef .OR. xsg2snow_p(jlayer)==xundef .OR. &
           xhistsnow_p(jlayer)==xundef .OR. xagesnow_p(jlayer)==xundef) &
           .AND. xwsnow_p(jlayer).NE.0. .AND. xwsnow_p(jlayer)/=xundef ) THEN
        WRITE(iluout,*) '----------------------------'
        WRITE(iluout,*) 'WSNOW/=0 AND ONE OF SG1SNOW,'
        WRITE(iluout,*) 'SG2SNOW, HISTSNOW OR AGESNOW'
        WRITE(iluout,*) '         ==XUNDEF           '
        WRITE(iluout,*) '    PLEASE CORRECT THAT     '
        WRITE(iluout,*) '----------------------------'
        CALL abor1_sfx('READ_PREP_ISBA_SNOW: ERROR IN INITIALISATION OF SNOW PARAMETERS')
      ENDIF
    ENDDO
    !
  ELSE
    !
    ALLOCATE(xsg1snow_p(0))
    ALLOCATE(xsg2snow_p(0))
    ALLOCATE(xhistsnow_p(0))
    !
  ENDIF
  !
  CALL close_namelist(hprogram,ilunam)
  !
ENDIF
!
hsnow = csnow
!
ksnow_layer = nsnow_layer
!
IF(all(xwsnow_p(:)==xundef).AND.present(ounif))THEN
    ounif=.false.
ELSEIF(present(ounif))THEN
    ounif=.true.
ENDIF
!
lfile=(len_trim(cfile_snow)>0.AND.len_trim(ctype_snow)>0 &
        .AND.len_trim(cfilepgd_snow)>0.AND.len_trim(ctypepgd_snow)>0)
!
IF(present(hfile))THEN 
  IF(lfile)THEN
     hfile = cfile_snow
  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
  ELSE
     hfilepgd = '                         '
  ENDIF
ENDIF
IF (lfile.AND.present(ounif)) ounif=.false.
!
IF (lhook) CALL dr_hook('READ_PREP_ISBA_SNOW',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
END SUBROUTINE read_prep_isba_snow