read_prep_isba_conf.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_conf(HPROGRAM,HVAR,HFILE,HFILETYPE,HFILEPGD,HFILEPGDTYPE,&
                                     hatmfile,hatmfiletype,hpgdfile,hpgdfiletype,kluout,ounif)
!     #######################################################
!
!!****  *READ_PREP_ISBA_CONF* - routine to read the configuration for ISBA
!!                              fields preparation
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      V. Masson   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004
!!      P. Samuelsson  02/2012  MEB
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
USE modi_read_prep_surf_atm_conf
!
USE modn_prep_isba
USE modd_prep_isba,  ONLY : cfile_isba, ctype, cfilepgd_isba, ctypepgd,        &
                            cfile_hug, ctype_hug,                              &
                            cfile_hug_surf, cfile_hug_root, cfile_hug_deep,    &
                            xhug_surf, xhug_root, xhug_deep,                   &
                            xhugi_surf, xhugi_root, xhugi_deep,                &
                            cfile_tg, ctype_tg,                                &
                            cfile_tg_surf, cfile_tg_root, cfile_tg_deep,       &
                            xtg_surf, xtg_root, xtg_deep,                      &  
                            xwsnow, xtsnow, xrsnow, xasnow
!
USE modd_surf_par,   ONLY : xundef
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*       0.1   Declarations of arguments
!              -------------------------
!
 CHARACTER(LEN=6),  INTENT(IN)  :: hprogram    ! program calling ISBA
 CHARACTER(LEN=7),  INTENT(IN)  :: hvar        ! variable treated
 CHARACTER(LEN=28), INTENT(OUT) :: hfile       ! file name
 CHARACTER(LEN=6),  INTENT(OUT) :: hfiletype   ! file type
 CHARACTER(LEN=28), INTENT(OUT) :: hfilepgd    ! file name
 CHARACTER(LEN=6),  INTENT(OUT) :: hfilepgdtype! file type
 CHARACTER(LEN=28), INTENT(IN)  :: hatmfile    ! atmospheric file name
 CHARACTER(LEN=6),  INTENT(IN)  :: hatmfiletype! atmospheric file type
 CHARACTER(LEN=28), INTENT(IN)  :: hpgdfile    ! atmospheric file name
 CHARACTER(LEN=6),  INTENT(IN)  :: hpgdfiletype! atmospheric file type
INTEGER,           INTENT(IN)  :: kluout      ! logical unit of output listing
LOGICAL,           INTENT(OUT) :: ounif       ! flag for prescribed uniform field

!
!*       0.2   Declarations of local variables
!              -------------------------------
!
REAL(KIND=JPRB) :: zhook_handle
!-------------------------------------------------------------------------------
!
!
IF (lhook) CALL dr_hook('READ_PREP_ISBA_CONF',0,zhook_handle)
hfile    = '                         '
hfiletype    = '      '
!
hfilepgd = '                         '
hfilepgdtype = '      '
!
ounif    = .false.
!
!-------------------------------------------------------------------------------
!
!* choice of input file
!  --------------------
!
SELECT CASE (hvar)
  CASE ('WG     ','WGI    ')
    IF (len_trim(cfile_hug)>0 .AND. len_trim(ctype_hug)>0 ) THEN
      hfile     = cfile_hug
      hfiletype = ctype_hug
    END IF
  CASE ('TG     ','TV     ','TC     ')
    IF (len_trim(cfile_tg)>0 .AND. len_trim(ctype_tg)>0 ) THEN
      hfile     = cfile_tg
      hfiletype = ctype_tg
    END IF
END SELECT
!
IF (len_trim(hfile)==0 .AND. len_trim(cfile_isba)>0 .AND. len_trim(ctype)>0) THEN
  hfile     = cfile_isba
  hfiletype = ctype
END IF
!
IF (len_trim(hfilepgd)==0 .AND. len_trim(cfilepgd_isba)>0 .AND. len_trim(ctypepgd)>0) THEN
  hfilepgd     = cfilepgd_isba
  hfilepgdtype = ctypepgd
END IF
!
!! If no file name in the scheme namelist,
!! try to find a name in NAM_SURF_ATM
!
IF (len_trim(hfile)==0) THEN
!
 CALL read_prep_surf_atm_conf(hprogram,hfile,hfiletype,hfilepgd,hfilepgdtype,&
                             hatmfile,hatmfiletype,hpgdfile,hpgdfiletype,kluout)
!
END IF
!
!! If no file name in the scheme namelist,
!! nor in NAM_SURF_ATM, look if ascii input files are present
!
SELECT CASE (hvar)
  CASE ('WG     ','WGI    ')
    IF ( len_trim(ctype_hug )>0       .AND. &
           len_trim(cfile_hug_surf)>0   .AND. &
           len_trim(cfile_hug_root)>0   .AND. &
           len_trim(cfile_hug_deep)>0         ) THEN  
       hfiletype = ctype_hug 
    END IF
    IF (hvar=='WGI    ' .AND. hfiletype=='ASCLLV') THEN
       ounif = .true.
       IF (xhugi_surf==xundef) xhugi_surf = 0.
       IF (xhugi_root==xundef) xhugi_root = 0.
       IF (xhugi_deep==xundef) xhugi_deep = 0.
       IF (lhook) CALL dr_hook('READ_PREP_ISBA_CONF',1,zhook_handle)
       RETURN
    ENDIF
  CASE ('TG     ','TV     ','TC     ')
    IF ( len_trim(ctype_tg )>0       .AND. &
           len_trim(cfile_tg_surf)>0   .AND. &
           len_trim(cfile_tg_root)>0   .AND. &
           len_trim(cfile_tg_deep)>0         ) THEN  
       hfiletype = ctype_tg 
    END IF
END SELECT
!
!-------------------------------------------------------------------------------
!
!* Is an uniform field prescribed?
!  ------------------------------
!
SELECT CASE (hvar)
  CASE ('WG     ')
    ounif = (xhug_surf/=xundef) .OR. (xhug_root/=xundef) .OR. (xhug_deep/=xundef)
    IF (ounif .AND. (xhug_surf==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUG_SURF, XHUG_ROOT OR XHUG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUG_SURF MUST BE SET')
    END IF
    IF (ounif .AND. (xhug_root==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUG_SURF, XHUG_ROOT OR XHUG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUG_ROOT MUST BE SET')
    END IF
    IF (ounif .AND. (xhug_deep==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUG_SURF, XHUG_ROOT OR XHUG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUG_DEEP MUST BE SET')
    END IF
    !
      CASE ('WGI    ')
    ounif = (xhugi_surf/=xundef) .OR. (xhugi_root/=xundef) .OR. (xhugi_deep/=xundef)
    IF (ounif .AND. (xhugi_surf==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUGI_SURF, XHUGI_ROOT OR XHUGI_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUGI_SURF MUST BE SET')
    END IF
    IF (ounif .AND. (xhugi_root==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUGI_SURF, XHUGI_ROOT OR XHUGI_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUGI_ROOT MUST BE SET')
    END IF
    IF (ounif .AND. (xhugi_deep==xundef)) THEN
       WRITE(kluout,*)'ONE OF XHUGI_SURF, XHUGI_ROOT OR XHUGI_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XHUGI_DEEP MUST BE SET')
    END IF
   !
  CASE ('TG     ','TV     ','TC     ')
    ounif = (xtg_surf/=xundef)  .OR. (xtg_root/=xundef)  .OR. (xtg_deep/=xundef)
    IF (ounif .AND. (xtg_surf==xundef)) THEN
       WRITE(kluout,*)'ONE OF XTG_SURF, XTG_ROOT OR XTG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XTG_SURF MUST BE SET')
    END IF
    IF (ounif .AND. (xtg_root==xundef)) THEN
       WRITE(kluout,*)'ONE OF XTG_SURF, XTG_ROOT OR XTG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XTG_ROOT MUST BE SET')
    END IF
    IF (ounif .AND. (xtg_deep==xundef)) THEN
       WRITE(kluout,*)'ONE OF XTG_SURF, XTG_ROOT OR XTG_DEEP IS GIVEN'
       CALL abor1_sfx('READ_PREP_ISBA_CONF: XTG_DEEP MUST BE SET')
    END IF
    !
END SELECT
!
!-------------------------------------------------------------------------------
!
!* no file given ? nor specific value in namelist? One takes the default value.
!
IF (hfiletype=='      ' .AND. .NOT. ounif) THEN
  IF (hvar(1:2)/='ZS') WRITE(kluout,*) 'NO FILE FOR FIELD ',hvar, &
                                        ': UNIFORM DEFAULT FIELD IS PRESCRIBED'
  IF (hvar(1:3)=='WGI') THEN
    xhugi_surf = 0.
    xhugi_root = 0.
    xhugi_deep = 0.
  ENDIF                                     
  ounif = .true.
END IF
IF (lhook) CALL dr_hook('READ_PREP_ISBA_CONF',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE read_prep_isba_conf