source: LMDZ6/trunk/libf/phylmd/ecrad.v1.5.1/radsurf_properties.F90 @ 5353

! radsurf_properties.f90 - Derived type for surface properties
!
! (C) Copyright 2017- ECMWF.
!
! This software is licensed under the terms of the Apache Licence Version 2.0
! which can be obtained at http://www.apache.org/licenses/LICENSE-2.0.
!
! In applying this licence, ECMWF does not waive the privileges and immunities
! granted to it by virtue of its status as an intergovernmental organisation
! nor does it submit to any jurisdiction.
!
! Author:  Robin Hogan
! Email:   r.j.hogan@ecmwf.int
!

module radsurf_properties

  use parkind1, only : jpim, jprb

  implicit none

  public

  ! Number of tile types
  integer(kind=jpim), parameter :: NTileTypes = 3

  ! Codes for the different type of tile
  enum, bind(c)
    enumerator :: ITileFlat = 1, &
         &        ITileVegetation, &
         &        ITileUrban3D
  end enum

  character(len=*), parameter :: TileRepresentationName(NTileTypes) &
       &  = (/ 'Flat                 ', &
       &       'HomogeneousVegetation', &
       &       'Urban3D              ' /)

  ! Number of surface facets and regions 
  integer(kind=jpim), parameter :: NTileFacets (NTileTypes) = (/ 1, 1, 3 /)
  integer(kind=jpim), parameter :: NTileRegions(NTileTypes) = (/ 0, 1, 1 /)


  !---------------------------------------------------------------------
  ! Derived type storing a physical description of the properties of
  ! the surface tiles needed to compute the boundary conditions for
  ! the radiation scheme.
  type surface_type
    ! Skin temperature (ncol,nfacet)
    real(kind=jprb), allocatable :: skin_temperature(:,:)

    ! Air temperature in canopy (ncol,ntile)
    real(kind=jprb), allocatable :: canopy_temperature(:,:)

    ! Shortwave albedo: if sw_albedo_direct is not allocated then
    ! sw_albedo will be used for both direct and diffuse solar
    ! radiation; otherwise, sw_albedo will be used for diffuse
    ! radiation and sw_albedo_direct for direct
    ! radiation. Dimensioning is (ncol,nalbedobands,nfacet).
    real(kind=jprb), allocatable, dimension(:,:,:) :: &
         &  sw_albedo, sw_albedo_direct

    ! Longwave emissivity: dimensioning is (ncol,nemissbands,nfacet)
    real(kind=jprb), allocatable, dimension(:,:,:) :: &
         &  lw_emissivity

    ! Representation codes (ITileFlat etc) for each tile: dimensioning
    ! is (ntile)
    integer(kind=jpim), allocatable, dimension(:) :: &
         &  i_representation

    ! Indices to the facets: dimensioning is (ncol,ntile)
    integer(kind=jpim), allocatable, dimension(:,:) :: &
         &  i_ground_facet, &
         &  i_roof_facet, &
         &  i_wall_facet

    ! Indices to the regions: dimensioning is (ncol,ntile)
    integer(kind=jpim), allocatable, dimension(:,:) :: &
         &  i_region_1 !, i_region_2

    ! Physical properties dimensioned (ncol,ntile)
    real(kind=jprb), allocatable, dimension(:,:) :: &
         &  tile_fraction, & ! Fraction of column occupied by each tile
         &  canopy_depth     ! Depth of canopy (m)

    ! Building properties in urban tile dimensioned (ncol,ntile)
    real(kind=jprb), allocatable, dimension(:,:) :: &
         &  building_fraction, & ! Fraction of canopy containing buildings
         &  building_normalized_perimeter ! Perimeter length of buildings per unit area (m)

    ! Vegetation physical properties dimensioned (ncol,ntile)
    real(kind=jprb), allocatable, dimension(:,:) :: &
         &  vegetation_optical_depth, & ! Same as LAI?
         &  vegetation_fractional_std   ! Fractional standard deviation

    ! Vegetation optical properties
    real(kind=jprb), allocatable, dimension(:,:,:) :: &
         &  vegetation_sw_albedo, & ! (ncol,nalbedobands,ntile)
         &  vegetation_lw_emissivity! (ncol,nemissbands,ntile)

! When 3D effects in vegetation canopies are represented, these will
! be available
!         &  vegetation_normalized_perimeter
!         &  vegetation_fraction, &

    ! Number of tiles, columns, facets, regions
    integer(kind=jpim) :: ntile, ncol, nfacet, nregion

    ! Number of albedo and emissivity bands
    integer(kind=jpim) :: nalbedobands, nemissbands

    ! Is this a simple surface containing one "flat" tile?
    logical :: is_simple = .true.

  contains
    procedure :: allocate   => allocate_surface
    procedure :: deallocate => deallocate_surface
    procedure :: read => read_from_netcdf
    procedure :: set_facet_indices

  end type surface_type


contains

  !---------------------------------------------------------------------
  subroutine allocate_surface(this, ncol, nalbedobands, nemissbands, &
       &                      i_representation, &
       &                      use_sw_albedo_direct)

    use yomhook,        only : lhook, dr_hook

    class(surface_type), intent(inout) :: this
    integer(kind=jpim),  intent(in)    :: ncol, nalbedobands, nemissbands
    integer(kind=jpim),  intent(in), optional :: i_representation(:)
    logical(kind=jpim),  intent(in), optional :: use_sw_albedo_direct

    ! Number of facets and regions
    integer(kind=jpim) :: nfacet, nregion, ntile

    real(jprb) :: hook_handle

    if (lhook) call dr_hook('radiation_surface:allocate',0,hook_handle)

    call this%deallocate()

    this%ncol   = ncol
    if (present(i_representation)) then
      nfacet    = sum(NTileFacets (i_representation))
      nregion   = sum(NTileRegions(i_representation))
      ntile     = size(i_representation)
      this%is_simple = .false.
    else
      nfacet    = 1
      nregion   = 0
      ntile     = 1
      this%is_simple = .true.
    end if
    this%nfacet = nfacet
    this%nregion= nregion
    this%ntile  = ntile
    this%nalbedobands = nalbedobands
    this%nemissbands  = nemissbands

    allocate(this%skin_temperature(ncol,nfacet))
    allocate(this%sw_albedo(ncol, nalbedobands, nfacet))

    if (present(use_sw_albedo_direct)) then
      if (use_sw_albedo_direct) then
        allocate(this%sw_albedo_direct(ncol, nalbedobands, nfacet))
      end if
    end if

    allocate(this%lw_emissivity(ncol, nemissbands, nfacet))

    if (this%ntile > 1) then
      allocate(this%tile_fraction(ncol,ntile))
    end if

    if (nregion > 0) then
      allocate(this%canopy_depth(ncol,ntile))
      allocate(this%canopy_temperature(ncol,ntile))
      this%canopy_depth = 0.0_jprb
      this%canopy_temperature = -1.0_jprb
    end if

    if (.not. this%is_simple) then
      allocate(this%i_representation(ntile))
      this%i_representation = i_representation

      if (any(i_representation == ITileUrban3D)) then
        allocate(this%building_fraction(ncol,ntile))
        allocate(this%building_normalized_perimeter(ncol,ntile))
        ! Initialize to default values
        this%building_fraction = 0.0_jprb
        this%building_normalized_perimeter = 0.0_jprb
      end if
      
      if (any(i_representation == ITileVegetation)) then
        allocate(this%vegetation_optical_depth(ncol,ntile))
        allocate(this%vegetation_fractional_std(ncol,ntile))
        allocate(this%vegetation_sw_albedo(ncol,nalbedobands,ntile))
        allocate(this%vegetation_lw_emissivity(ncol,nemissbands,ntile))
        ! Initialize to default values
        this%vegetation_optical_depth = 0.0_jprb
        this%vegetation_fractional_std = 0.0_jprb
        this%vegetation_sw_albedo = 0.0_jprb
        this%vegetation_lw_emissivity = 1.0_jprb
      end if
      
      call this%set_facet_indices 

    end if

    if (lhook) call dr_hook('radiation_surface:allocate',1,hook_handle)

  end subroutine allocate_surface


  !---------------------------------------------------------------------
  ! Set the indices to facets
  subroutine set_facet_indices(this)

    use radiation_io,   only : nulerr, radiation_abort

    class(surface_type), intent(inout) :: this

    ! Indices to tiles and facets
    integer(kind=jpim) :: ifacet, iregion, jtile
    if (.not. this%is_simple) then

      allocate(this%i_ground_facet(this%ncol,this%ntile))
      this%i_ground_facet = 0

      if (any(this%i_representation == ITileUrban3D)) then
        allocate(this%i_roof_facet(this%ncol,this%ntile))
        allocate(this%i_wall_facet(this%ncol,this%ntile))
        ! Initialize to default values
        this%i_roof_facet = 0
        this%i_wall_facet = 0
      end if
      
      if (this%nregion > 0) then
        allocate(this%i_region_1(this%ncol,this%ntile))
        this%i_region_1 = 0
      end if

      ! Set the indices to the various facets
      ifacet = 1
      iregion = 1
      do jtile = 1,this%ntile
        this%i_ground_facet(:,jtile) = ifacet
        ifacet = ifacet + 1
        if (this%i_representation(jtile) == ITileVegetation) then
          this%i_region_1(:,jtile) = iregion
          iregion = iregion+1
        else if (this%i_representation(jtile) == ITileUrban3D) then
          this%i_roof_facet(:,jtile) = ifacet
          this%i_wall_facet(:,jtile) = ifacet+1
          ifacet = ifacet+2
          this%i_region_1(:,jtile) = iregion
          iregion = iregion+1
        else if (this%i_representation(jtile) /= ITileFlat) then
          write(nulerr,'(a,i0,a)') '*** Error: tile representation ', &
               &  this%i_representation(jtile), ' not understood'
          call radiation_abort()
        end if
      end do
    end if
  end subroutine set_facet_indices

  !---------------------------------------------------------------------
  subroutine deallocate_surface(this)

    use yomhook, only : lhook, dr_hook

    class(surface_type), intent(inout) :: this

    real(jprb) :: hook_handle

    if (lhook) call dr_hook('radiation_surface:deallocate',0,hook_handle)

    if (allocated(this%skin_temperature)) then
      deallocate(this%skin_temperature)
    end if
    if (allocated(this%sw_albedo)) then
      deallocate(this%sw_albedo)
    end if
    if (allocated(this%sw_albedo_direct)) then
      deallocate(this%sw_albedo_direct)
    end if
    if (allocated(this%lw_emissivity)) then
      deallocate(this%lw_emissivity)
    end if
    if (allocated(this%i_representation)) then
      deallocate(this%i_representation)
    end if
    if (allocated(this%i_ground_facet)) then
      deallocate(this%i_ground_facet)
    end if
    if (allocated(this%i_roof_facet)) then
      deallocate(this%i_roof_facet)
    end if
    if (allocated(this%i_wall_facet)) then
      deallocate(this%i_wall_facet)
    end if
    if (allocated(this%tile_fraction)) then
      deallocate(this%tile_fraction)
    end if
    if (allocated(this%canopy_depth)) then
      deallocate(this%canopy_depth)
    end if
    if (allocated(this%canopy_temperature)) then
      deallocate(this%canopy_temperature)
    end if
    if (allocated(this%building_fraction)) then
      deallocate(this%building_fraction)
    end if
    if (allocated(this%building_normalized_perimeter)) then
      deallocate(this%building_normalized_perimeter)
    end if
    if (allocated(this%vegetation_optical_depth)) then
      deallocate(this%vegetation_optical_depth)
    end if
    if (allocated(this%vegetation_fractional_std)) then
      deallocate(this%vegetation_fractional_std)
    end if
    if (allocated(this%vegetation_sw_albedo)) then
      deallocate(this%vegetation_sw_albedo)
    end if
    if (allocated(this%vegetation_lw_emissivity)) then
      deallocate(this%vegetation_lw_emissivity)
    end if

    this%ntile  = 0
    this%ncol   = 0
    this%nfacet = 0

    if (lhook) call dr_hook('radiation_surface:deallocate',1,hook_handle)

  end subroutine deallocate_surface


  !---------------------------------------------------------------------
  ! Print a description of the surface tile types
  subroutine print_surface_representation(i_representation)

    use radiation_io, only : nulout

    integer(kind=jpim), dimension(:), allocatable, intent(in) :: i_representation

    integer :: ntile, jtile, ifacet, iregion

    write(nulout,'(a)') 'Surface tile representation:'
    if (.not. allocated(i_representation)) then
      write(nulout,'(a)') '  Simple (one flat tile)'
    else
      ntile = size(i_representation,1)
      ifacet  = 1
      iregion = 1;
      do jtile = 1,ntile
        write(nulout,'(a,i0,a,a)') '  Tile ', jtile, ': ', trim(TileRepresentationName(i_representation(jtile)))
        write(nulout,'(a,i0,a)') '    Facet ', ifacet, ': ground'
        ifacet = ifacet+1

        select case (i_representation(jtile))

        case (ITileVegetation)
          write(nulout,'(a,i0,a)') '    Region ', iregion, ': vegetation canopy'
          iregion = iregion+1

        case (ITileUrban3D)
          write(nulout,'(a,i0,a)') '    Facet ', ifacet, ': roof'
          write(nulout,'(a,i0,a)') '    Facet ', ifacet+1, ': wall'
          ifacet = ifacet+1
          write(nulout,'(a,i0,a)') '    Region ', iregion, ': street canyon'
          iregion = iregion+1

        end select

      end do
    end if
    
  end subroutine print_surface_representation


  !---------------------------------------------------------------------
  subroutine read_from_netcdf(this, file)

    use parkind1,           only : jprb, jpim
    use easy_netcdf,        only : netcdf_file
    
    implicit none

    type(netcdf_file),  intent(in)     :: file
    class(surface_type), intent(inout) :: this

    real(kind=jprb), allocatable       :: data_1d(:)

    integer(kind=jpim), parameter :: ipermute(3) = [2,3,1]

    call this%deallocate

    this%is_simple = .false.

    call file%get('skin_temperature', this%skin_temperature, do_transp=.true.)
    call file%get('canopy_temperature', this%canopy_temperature, do_transp=.true.)
    call file%get('sw_albedo', this%sw_albedo, ipermute=ipermute)
    if (file%exists('sw_albedo_direct')) then
      call file%get('sw_albedo', this%sw_albedo_direct, ipermute=ipermute)
    end if
    call file%get('lw_emissivity', this%lw_emissivity, ipermute=ipermute)
    call file%get('tile_representation', data_1d)
    this%ntile = size(data_1d)
    allocate(this%i_representation(this%ntile))
    this%i_representation = int(data_1d)
    call file%get('tile_fraction', this%tile_fraction, do_transp=.true.)
    call file%get('canopy_depth', this%canopy_depth, do_transp=.true.)
    call file%get('building_fraction', this%building_fraction, do_transp=.true.)
    if (file%exists('building_normalized_perimeter')) then
      call file%get('building_normalized_perimeter', &
           &  this%building_normalized_perimeter, do_transp=.true.)
    else
      ! Convert building scale to normalized perimeter
      call file%get('building_scale', this%building_normalized_perimeter, do_transp=.true.)
      this%building_normalized_perimeter = 4.0_jprb * this%building_fraction &
           &  * (1.0_jprb-this%building_fraction) / max(1.0e-8_jprb,this%building_normalized_perimeter)
    end if
    call file%get('vegetation_optical_depth', this%vegetation_optical_depth, do_transp=.true.)
    call file%get('vegetation_sw_albedo', this%vegetation_sw_albedo, ipermute=ipermute)
    call file%get('vegetation_lw_emissivity', this%vegetation_lw_emissivity, ipermute=ipermute)

    this%nregion = sum(NTileRegions(this%i_representation))
    this%ncol    = size(this%skin_temperature,1)
    this%nfacet  = size(this%skin_temperature,2)

    this%nalbedobands = size(this%sw_albedo,2)
    this%nemissbands = size(this%lw_emissivity,2)

    call this%set_facet_indices

  end subroutine read_from_netcdf


end module radsurf_properties