read_teb_date.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_teb_date (&
                                hprogram,hinit,kluout,hatmfile,hatmfiletype,&
                                 kyear,kmonth,kday,ptime,tptime)  
!     #######################################################
!
!!****  *READ_TEB_DATE* - routine to initialise de date TTIME of MODD_TEB
!!
!!    PURPOSE
!!    -------
!!
!!**  METHOD
!!    ------
!!
!!    EXTERNAL
!!    --------
!!
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!
!!    AUTHOR
!!    ------
!!      S.Malardel   *Meteo France*
!!
!!    MODIFICATIONS
!!    -------------
!!      Original    01/2004 
!!      P. Le Moigne 10/2005, Phasage Arome
!-------------------------------------------------------------------------------
!
!*       0.    DECLARATIONS
!              ------------
!
!
!
!
USE modd_type_date_surf
USE modd_surf_par,       ONLY : nundef, xundef
!
USE modi_read_prep_teb_date_conf
USE modi_read_pre_surfa_dat_conf
USE modi_read_prep_teb_conf
USE modi_read_prep_file_date
!
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
 CHARACTER(LEN=3),  INTENT(IN)  :: hinit     ! fields to initialize 'ALL', 'PRE', 'PGD'
 CHARACTER(LEN=28), INTENT(IN)  :: hatmfile    ! atmospheric file name
 CHARACTER(LEN=6),  INTENT(IN)  :: hatmfiletype! atmospheric file type
INTEGER,           INTENT(IN)  :: kyear     ! current year (UTC)
INTEGER,           INTENT(IN)  :: kmonth    ! current month (UTC)
INTEGER,           INTENT(IN)  :: kday      ! current day (UTC)
REAL,              INTENT(IN)  :: ptime     ! current time since midnight (UTC, s)
TYPE (date_time),  INTENT(OUT) ::tptime    ! time and date
INTEGER,           INTENT(IN)  :: kluout      ! logical unit of output listing
!
!
!*       0.2   Declarations of local variables
!              -------------------------------
!
 CHARACTER(LEN=28)              :: yfile       ! file name
 CHARACTER(LEN=6)               :: yfiletype   ! file type
 CHARACTER(LEN=28)              :: yfilepgd       ! file name
 CHARACTER(LEN=6)               :: yfilepgdtype   ! file type
 CHARACTER(LEN=28)              :: yfilepgdin       ! file name
 CHARACTER(LEN=6)               :: yfilepgdintype   ! file type
!
LOGICAL                        :: gunif       ! flag for prescribed uniform field
REAL(KIND=JPRB) :: zhook_handle
!
!-------------------------------------------------------------------------------
!
IF (lhook) CALL dr_hook('READ_TEB_DATE',0,zhook_handle)
yfile     = '                         '
yfiletype = '      '
!
yfilepgdin     = '                         '
yfilepgdintype = '      '
!
!-------------------------------------------------------------------------------
!
!* look for a date in the namelist NAM_PREP_TEB or NAM_PREP_SURF_ATM
!-------------------------------------------------------------------
!
 CALL read_prep_teb_date_conf(hprogram,kluout,tptime)
!
IF (tptime%TDATE%YEAR==nundef.OR.tptime%TDATE%MONTH==nundef &
      .OR.tptime%TDATE%DAY==nundef.OR.tptime%TIME==xundef) THEN  
  CALL read_pre_surfa_dat_conf(hprogram,kluout,tptime)
END IF
!
!* If no date in the namelist, look for a file
!  ---------------
!
IF (tptime%TDATE%YEAR==nundef.OR.tptime%TDATE%MONTH==nundef &
      .OR.tptime%TDATE%DAY==nundef.OR.tptime%TIME==xundef) THEN  
  !
  CALL read_prep_teb_conf(hprogram,'DATE   ',yfile,yfiletype,yfilepgd,yfilepgdtype,&
                          hatmfile,hatmfiletype,yfilepgdin,yfilepgdintype,kluout,gunif)
  !
  IF (len_trim(yfiletype)/=0) THEN
    CALL read_prep_file_date(&
                             hprogram,yfile,yfiletype,tptime,kluout)
  END IF
  !
END IF
!
!* If no file and no date in the namelist, test if atmospheric date
!------------------------------------------------------------------
!
IF (len_trim(yfile)==0 .AND. (tptime%TDATE%YEAR==nundef.OR.tptime%TDATE%MONTH==nundef &
                               .OR.tptime%TDATE%DAY==nundef.OR.tptime%TIME==xundef)) THEN  
!
  IF (kyear /= nundef .AND. kmonth /= nundef .AND. kday /= nundef .AND. ptime /= xundef) THEN
    tptime%TDATE%YEAR = kyear
    tptime%TDATE%MONTH= kmonth
    tptime%TDATE%DAY  = kday
    tptime%TIME = ptime
  ELSE
!
!* If no file, no date in the namelist and no atmospheric date : stop
!-----------------------------------------------------------------------
!
   CALL abor1_sfx('READ_TEB_DATE: DATE NOT SET')
  END IF
ENDIF
!
!* Test of date coherence?
!------------------------ 
!
IF (kyear /= nundef .AND. kmonth /= nundef .AND. kday /= nundef .AND. ptime /= xundef) THEN
  IF (kyear /= tptime%TDATE%YEAR .OR. kmonth /= tptime%TDATE%MONTH .OR. kday /= tptime%TDATE%DAY .AND. ptime /= tptime%TIME) THEN
    WRITE(unit=kluout, fmt=*)'WARNING in READ_TEB_DATE'
    WRITE(unit=kluout, fmt=*)'ATMOSPHERIC AND SURFACE DATES ARE NOT THE SAME'
    WRITE(unit=kluout, fmt=*)'ATMOSPHERIC DATE:'
    WRITE(unit=kluout, fmt='(" YEAR=",I4)') kyear
    WRITE(unit=kluout, fmt='(" MONTH=",I4)') kmonth
    WRITE(unit=kluout, fmt='(" DAY=",I4)') kday
    WRITE(unit=kluout, fmt='(" TIME=",E13.6)') ptime
    WRITE(unit=kluout, fmt=*)'SURFACE DATE:'
    WRITE(unit=kluout, fmt='(" YEAR=",I4)') tptime%TDATE%YEAR
    WRITE(unit=kluout, fmt='(" MONTH=",I4)') tptime%TDATE%MONTH
    WRITE(unit=kluout, fmt='(" DAY=",I4)') tptime%TDATE%DAY
    WRITE(unit=kluout, fmt='(" TIME=",E13.6)') tptime%TIME
  ELSE
    WRITE(unit=kluout, fmt=*)'SAME ATMOSPHERIC AND SURFACE DATES'
    WRITE(unit=kluout, fmt=*)'DATE in READ_TEB_DATE'
    WRITE(unit=kluout, fmt='(" YEAR=",I4," MONTH=",I4," DAY=",I4)') &
                                        kyear,kmonth,kday  
    WRITE(unit=kluout, fmt='(" TIME=",E13.6)') ptime
  ENDIF
ENDIF
IF (lhook) CALL dr_hook('READ_TEB_DATE',1,zhook_handle)
!------------------------------------------------------------------------------
!
END SUBROUTINE read_teb_date