pgd_ecoclimap2_data.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 pgd_ecoclimap2_data (DTCO, &
                                      hprogram)
!     #########################
!
!!**** *PGD_ECOCLIMAP2_DATA* initializes cover-field correspondance arrays
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!
!!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    15/12/97
!!    F.solmon    01/06/00 adaptation for patch approach
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------

!
USE modd_data_cover_n, ONLY : data_cover_t
!
USE modd_surf_par,       ONLY : xundef, nundef
!
USE modd_data_cover,     ONLY : tdata_seed, tdata_reap, xdata_watsup, xdata_irrig,&
                                  ldata_irrig, xdata_vegtype, lclim_lai  

!

USE modd_data_cover_par, ONLY : nvt_irr, jpcover
!
USE modi_get_luout
USE modi_open_namelist
USE modi_close_namelist
USE modi_open_file
USE modi_close_file
!
USE mode_pos_surf
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
USE modi_ecoclimap2_lai
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
!
 CHARACTER(LEN=6),    INTENT(IN)    :: hprogram     ! Type of program
!
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER               :: iglb      ! logical units
INTEGER               :: iluout    ! output listing logical unit
INTEGER               :: ierr      ! return codes
INTEGER               :: ilunam    ! namelist file  logical unit
LOGICAL               :: gfound    ! true if namelist is found
!
INTEGER               :: jcover,jdec,jvegtype ! loop counters on covers and decades
!
INTEGER, DIMENSION(:), ALLOCATABLE   :: ivalue   ! value of a record of data points

!
!*    0.3    Declaration of namelists
!            ------------------------
!
 CHARACTER(LEN=28)        :: yirrig   ! file name for irrigation
REAL(KIND=JPRB) :: zhook_handle
!                                        
namelist/nam_ecoclimap2/  yirrig, lclim_lai
!-------------------------------------------------------------------------------

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
!
!*    1.      Read namelist
!  -------------------------------------
!
!* Initializations 
!
IF (lhook) CALL dr_hook('PGD_ECOCLIMAP2_DATA',0,zhook_handle)
yirrig         = '                          '
lclim_lai      = .true.
dtco%NYEAR          = nundef
!
!* Reading
!
 CALL get_luout(hprogram,iluout)
 CALL open_namelist(hprogram,ilunam)
!
 CALL posnam(ilunam,'NAM_ECOCLIMAP2',gfound,iluout)
IF (gfound) READ(unit=ilunam,nml=nam_ecoclimap2)
!
 CALL close_namelist(hprogram,ilunam)
!
!-------------------------------------------------------------------------------
!
!*    2.         Verifications
!               ----------------
!
  ldata_irrig=(len_trim(yirrig)>0)
!
!-------------------------------------------------------------------------------
!
!
!*   3.    second version of ecoclimap (europe)
!          ----------------------------------- 
!
!
!*   3.1.   read the irrigation data
!           ----------------------
!
ierr=0

IF (len_trim(yirrig)>0) THEN
ALLOCATE(ivalue(7))    

 CALL open_file(hprogram,iglb,yirrig,'FORMATTED',haction='READ') 
               
DO jcover=301,jpcover
  READ(iglb,fmt='(7I4)') ivalue
  IF (xdata_vegtype(jcover,nvt_irr).NE.0) THEN
    tdata_seed(jcover,nvt_irr )%TDATE%MONTH = ivalue(2)
    tdata_seed(jcover,nvt_irr )%TDATE%DAY   = ivalue(3)
    tdata_reap(jcover,nvt_irr )%TDATE%MONTH = ivalue(4)
    tdata_reap(jcover,nvt_irr )%TDATE%DAY   = ivalue(5)
    xdata_watsup(jcover,nvt_irr) = ivalue(6)
    xdata_irrig(jcover,nvt_irr) = ivalue(7)
  ENDIF
  !
  IF (xdata_vegtype(jcover,nvt_irr).NE.0 .AND. &
      (ivalue(2).EQ.0 .OR. ivalue(3).EQ.0 .OR. ivalue(4).EQ.0 .OR. &
      ivalue(5).EQ.0 .OR. ivalue(6).EQ.0 .OR. ivalue(7).EQ.0)) THEN    
      WRITE(iluout,*)'**************************************************'
      WRITE(iluout,*)'* error, missing data in ',yirrig,' for          *'
      WRITE(iluout,*)'* the class ',jcover,'.                          *'
     WRITE(iluout,*)'**************************************************'
     ierr=1
   ENDIF
   IF (xdata_vegtype(jcover,nvt_irr).EQ.0 .AND. &
      (ivalue(2).NE.0 .OR. ivalue(3).NE.0 .OR. ivalue(4).NE.0 .OR. &
      ivalue(5).NE.0 .OR. ivalue(6).NE.0 .OR. ivalue(7).NE.0)) THEN    
      WRITE(iluout,*)'**************************************************'
      WRITE(iluout,*)'* error, too many data in ',yirrig,' for         *'
      WRITE(iluout,*)'* the class ',jcover,'.                          *'
      WRITE(iluout,*)'**************************************************'
     ierr=1
   ENDIF
ENDDO
                
 CALL close_file(hprogram,iglb)

IF (ierr.EQ.1) CALL abor1_sfx('PGD_ECOCLIMAP2_DATA (3)')

DEALLOCATE(ivalue)
END IF
!
!-------------------------------------------------------------------------------
!
!    4.    Computes LAI evolution for the chosen year
!          ------------------------------------------
!
 CALL ecoclimap2_lai(dtco)
IF (lhook) CALL dr_hook('PGD_ECOCLIMAP2_DATA',1,zhook_handle)
!
!-------------------------------------------------------------------------------
!
END SUBROUTINE pgd_ecoclimap2_data