pgd_frac.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_frac (DTCO, UG, U, USS, &
                           hprogram,oecoclimap)
!     ##############################################################
!
!!**** *PGD_FRAC* monitor for averaging and interpolations of cover fractions
!!
!!    PURPOSE
!!    -------
!!
!!    METHOD
!!    ------
!!   
!
!!    EXTERNAL
!!    --------
!!
!!    IMPLICIT ARGUMENTS
!!    ------------------
!!
!!    REFERENCE
!!    ---------
!!
!!    AUTHOR
!!    ------
!!
!!    V. Masson        Meteo-France
!!
!!    MODIFICATION
!!    ------------
!!
!!    Original    10/12/97
!!
!!       Modified 08/12/05, P. Le Moigne: user defined fields
!!       Modified 04/2013   V. Masson   : set a cover containing garden for TOWN default
!----------------------------------------------------------------------------
!
!*    0.     DECLARATION
!            -----------
!
!
!
USE modd_data_cover_n, ONLY : data_cover_t
USE modd_surf_atm_grid_n, ONLY : surf_atm_grid_t
USE modd_surf_atm_n, ONLY : surf_atm_t
USE modd_surf_atm_sso_n, ONLY : surf_atm_sso_t
!
USE modd_surf_par,       ONLY : xundef
USE modd_pgd_grid,       ONLY : nl, cgrid
USE modd_data_cover_par, ONLY : jpcover
!
USE modd_pgdwork,        ONLY : catype
!
USE modi_get_luout
USE modi_open_namelist
USE modi_close_namelist
USE modi_pgd_field
USE modi_sum_on_all_procs
!
USE mode_pos_surf
!
!
USE yomhook   ,ONLY : lhook,   dr_hook
USE parkind1  ,ONLY : jprb
!
USE modi_abor1_sfx
!
IMPLICIT NONE
!
!*    0.1    Declaration of arguments
!            ------------------------
!
!
TYPE(data_cover_t), INTENT(INOUT) :: dtco
TYPE(surf_atm_grid_t), INTENT(INOUT) :: ug
TYPE(surf_atm_t), INTENT(INOUT) :: u
TYPE(surf_atm_sso_t), INTENT(INOUT) :: uss
!
 CHARACTER(LEN=6),    INTENT(IN)    :: hprogram     ! Type of program
LOGICAL,             INTENT(OUT)   :: oecoclimap   ! F if fractions prescribed by user
!                                                  ! T if fractions will be computed from ecoclimap
!
!*    0.2    Declaration of local variables
!            ------------------------------
!
INTEGER               :: iluout    ! output listing logical unit
INTEGER               :: ilunam    ! namelist file  logical unit
LOGICAL               :: gfound    ! true if namelist is found
!
INTEGER               :: jcover    ! loop counter on covers
!
REAL, DIMENSION(NL)   :: zsum      ! sum of 4 tiles fractions
!
!*    0.3    Declaration of namelists
!            ------------------------
!
LOGICAL  :: lecoclimap  ! F if ecoclimap is not used
REAL     :: xunif_sea   ! value of sea    fraction
REAL     :: xunif_water ! value of water  fraction
REAL     :: xunif_nature! value of nature fraction
REAL     :: xunif_town  ! value of town   fraction
!
! name of files containing data
!
 CHARACTER(LEN=28)     :: cfnam_sea    ! name of sea    file
 CHARACTER(LEN=28)     :: cfnam_water  ! name of water  file
 CHARACTER(LEN=28)     :: cfnam_nature ! name of nature file
 CHARACTER(LEN=28)     :: cfnam_town   ! name of town   file
!
! type of files containing data
!
 CHARACTER(LEN=6)      :: cftyp_sea    ! type of sea    file
 CHARACTER(LEN=6)      :: cftyp_water  ! type of water  file
 CHARACTER(LEN=6)      :: cftyp_nature ! type of nature file
 CHARACTER(LEN=6)      :: cftyp_town   ! type of town   file
!
INTEGER               :: icover       ! 0 if cover is not present, >1 if present somewhere
!                                     ! (even on another processor)
INTEGER               :: icpt
!
REAL(KIND=JPRB) :: zhook_handle
!
!
namelist/nam_frac/ lecoclimap,                                         &
                     xunif_sea, xunif_water, xunif_nature, xunif_town, &
                     cfnam_sea, cfnam_water, cfnam_nature, cfnam_town, &
                     cftyp_sea, cftyp_water, cftyp_nature, cftyp_town  
!-------------------------------------------------------------------------------
!
!*    1.      Initializations
!             ---------------
!
IF (lhook) CALL dr_hook('PGD_FRAC',0,zhook_handle)
xunif_sea      = xundef
xunif_water    = xundef
xunif_nature   = xundef
xunif_town     = xundef
lecoclimap     = .true.
 cfnam_sea(:)= '                            '
 cfnam_water(:)= '                            '
 cfnam_nature(:)= '                            '
 cfnam_town(:)= '                            '
 cftyp_sea(:)= '      '
 cftyp_water(:)= '      '
 cftyp_nature(:)= '      '
 cftyp_town(:)= '      '
!
oecoclimap = .true.
!
!-------------------------------------------------------------------------------
!
!*    2.      Input file for cover types
!             --------------------------
!
 CALL get_luout(hprogram,iluout)
 CALL open_namelist(hprogram,ilunam)
!
 CALL posnam(ilunam,'NAM_FRAC',gfound,iluout)
IF (gfound) READ(unit=ilunam,nml=nam_frac)
!
 CALL close_namelist(hprogram,ilunam)
!
!-------------------------------------------------------------------------------
!
IF ((len_trim(cfnam_sea)/=0 .OR. xunif_sea/=xundef) .AND. (len_trim(cfnam_water)/=0 .OR. xunif_water/=xundef) .AND. &
    (len_trim(cfnam_nature)/=0 .OR. xunif_nature/=xundef) .AND. (len_trim(cfnam_town)/=0 .OR. xunif_town/=xundef)) THEN
!
  ALLOCATE(u%XSEA   (nl))
  ALLOCATE(u%XWATER (nl))
  ALLOCATE(u%XNATURE(nl))
  ALLOCATE(u%XTOWN  (nl))
!
!*    3.      Uniform fractions are prescribed
!             --------------------------------
!
  IF (xunif_sea/=xundef .AND. xunif_water/=xundef .AND. xunif_nature/=xundef .AND.  xunif_town/=xundef) THEN
!
!*    3.1     Verification of the total input cover fractions
!             -----------------------------------------------
!
    IF (abs(xunif_sea+xunif_water+xunif_nature+xunif_town-1.)>1.e-6) THEN
      WRITE(iluout,*) ' '
      WRITE(iluout,*) '*********************************************************'
      WRITE(iluout,*) '* Error in fractions preparation                        *'
      WRITE(iluout,*) '* The prescribed fractions do not fit                   *'
      WRITE(iluout,*) '* The sum of all 4 fractions must be equal to 1 exactly *'
      WRITE(iluout,*) '*********************************************************'
      WRITE(iluout,*) ' '
      CALL abor1_sfx('PGD_FRAC: SUM OF ALL FRACTIONS MUST BE 1.')
!
!*    3.2     Use of the presribed cover fractions
!             ------------------------------------
!
    ELSE
!
      u%XSEA    = xunif_sea 
      u%XWATER  = xunif_water
      u%XNATURE = xunif_nature
      u%XTOWN   = xunif_town

    END IF
!
!*    3.3     No data
!             -------
!
  ELSE

    catype = 'ARI'
    IF (xunif_sea==xundef) THEN
      CALL pgd_field(dtco, ug, u, uss, &
                     hprogram,'XSEA: sea fraction      ','ALL', cfnam_sea   , &
                    cftyp_sea   , xunif_sea   , u%XSEA(:)   )  
    ELSE                 
      u%XSEA(:) = xunif_sea
    ENDIF
    IF (xunif_water==xundef) THEN
      CALL pgd_field(dtco, ug, u, uss, &
                     hprogram,'XWATER: water fraction  ','ALL', cfnam_water , &
                    cftyp_water , xunif_water , u%XWATER(:) )  
    ELSE                    
      u%XWATER(:) = xunif_water
    ENDIF
    IF (xunif_nature==xundef) THEN
      CALL pgd_field(dtco, ug, u, uss, &
                     hprogram,'XNATURE: nature fraction','ALL', cfnam_nature, &
                    cftyp_nature, xunif_nature, u%XNATURE(:))  
    ELSE                    
      u%XNATURE(:) = xunif_nature
    ENDIF
    IF (xunif_town==xundef) THEN
      CALL pgd_field(dtco, ug, u, uss, &
                     hprogram,'XTOWN: town fraction    ','ALL', cfnam_town  , &
                    cftyp_town  , xunif_town  , u%XTOWN(:)  )  
    ELSE                    
      u%XTOWN(:) = xunif_town
    ENDIF
  ENDIF

ELSE
!
!*    4.      No prescription of fractions
!             ----------------------------
!
  IF (lhook) CALL dr_hook('PGD_FRAC',1,zhook_handle)
  RETURN
!
ENDIF
!-------------------------------------------------------------------------------
!         consistency check
!         ------------------
!
zsum(:) = u%XSEA(:) + u%XNATURE(:) + u%XWATER(:) + u%XTOWN(:)

u%XSEA(:)    = u%XSEA(:)    / zsum(:)
u%XNATURE(:) = u%XNATURE(:) / zsum(:)
u%XWATER(:)  = u%XWATER(:)  / zsum(:)
u%XTOWN(:)   = u%XTOWN(:)   / zsum(:)
!
!-------------------------------------------------------------------------------

WRITE(iluout,*) ' '
!-------------------------------------------------------------------------------
!
oecoclimap = lecoclimap
!
!*    5.      List of cover present
!             ---------------------
!
IF (.NOT.lecoclimap) THEN

  ALLOCATE(u%LCOVER(jpcover))
  u%LCOVER(:) = .false.
  icover = 0
  icpt= sum_on_all_procs(hprogram,cgrid,u%XSEA(:)/=0. ,'COV')
  IF (icpt/=0) THEN
    u%LCOVER(1) = .true.
    icover=icover+1
  ENDIF
  icpt= sum_on_all_procs(hprogram,cgrid,u%XWATER(:)/=0. ,'COV')
  IF (icpt/=0) THEN  
    u%LCOVER(2) = .true.
    icover=icover+1
  ENDIF
  icpt= sum_on_all_procs(hprogram,cgrid,u%XNATURE(:)/=0. ,'COV')
  IF (icpt/=0) THEN  
    u%LCOVER(4) = .true.
    icover=icover+1
  ENDIF
  icpt= sum_on_all_procs(hprogram,cgrid,u%XTOWN(:)/=0. ,'COV')
  IF (icpt/=0) THEN  
    u%LCOVER(151) = .true.
    icover=icover+1
  ENDIF

  ALLOCATE(u%XCOVER (nl,icover))

  icpt = 0
  IF (u%LCOVER(1)) THEN
    icpt = icpt + 1
    u%XCOVER(:,icpt) = u%XSEA(:)
  ENDIF
  IF (u%LCOVER(2)) THEN
    icpt = icpt + 1
    u%XCOVER(:,icpt) = u%XWATER(:)
  ENDIF
  IF (u%LCOVER(4)) THEN
    icpt = icpt + 1
    u%XCOVER(:,icpt) = u%XNATURE(:)
  ENDIF
  IF (u%LCOVER(151)) THEN
    icpt = icpt + 1
    u%XCOVER(:,icpt) = u%XTOWN(:)
  ENDIF
  
  ! comment V. Masson: to use this cover type for town by default avoids crashes
  ! when garden fraction is specified but no garden vegetation parameters.
  ! In this cas, the properties for garden come from the cover 151
!
!
!-------------------------------------------------------------------------------
!
!*    6.      Land - sea fractions
!             --------------------
!
  u%NSIZE_NATURE    = count(u%XNATURE(:) > 0.0)
  u%NSIZE_WATER     = count(u%XWATER (:) > 0.0)
  u%NSIZE_SEA       = count(u%XSEA   (:) > 0.0)
  u%NSIZE_TOWN      = count(u%XTOWN  (:) > 0.0)
  u%NSIZE_FULL      = nl
!
  u%NDIM_NATURE    = sum_on_all_procs(hprogram,cgrid,u%XNATURE(:) > 0.0, 'DIM')
  u%NDIM_WATER     = sum_on_all_procs(hprogram,cgrid,u%XWATER (:) > 0.0, 'DIM')
  u%NDIM_SEA       = sum_on_all_procs(hprogram,cgrid,u%XSEA   (:) > 0.0, 'DIM')
  u%NDIM_TOWN      = sum_on_all_procs(hprogram,cgrid,u%XTOWN  (:) > 0.0, 'DIM')
!  
ENDIF
IF (lhook) CALL dr_hook('PGD_FRAC',1,zhook_handle)
!-------------------------------------------------------------------------------
!
END SUBROUTINE pgd_frac