scale_landuse.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
module scale_landuse
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: landuse_setup
  public :: landuse_calc_fact
  public :: landuse_write

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  real(RP), public, allocatable :: landuse_fact_ocean(:,:)
  real(RP), public, allocatable :: landuse_fact_land (:,:)
  real(RP), public, allocatable :: landuse_fact_urban(:,:)

  real(RP), public, allocatable :: landuse_frac_land (:,:)
  real(RP), public, allocatable :: landuse_frac_lake (:,:)
  real(RP), public, allocatable :: landuse_frac_urban(:,:)

  integer,  public              :: landuse_pft_mosaic = 2
  integer,  public              :: landuse_pft_nmax   = 15

  real(RP), public, allocatable :: landuse_frac_pft (:,:,:)
  integer,  public, allocatable :: landuse_index_pft(:,:,:)

  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  private :: landuse_read

  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  character(len=H_LONG),  private :: landuse_in_basename  = ''
  logical,                private :: landuse_in_check_coordinates = .true.      
  character(len=H_LONG),  private :: landuse_out_basename = ''
  character(len=H_MID),   private :: landuse_out_title    = 'SCALE-RM LANDUSE'
  character(len=H_SHORT), private :: landuse_out_dtype    = 'DEFAULT'
  logical,                private :: landuse_allocean     = .false.
  logical,                private :: landuse_allland      = .false.
  logical,                private :: landuse_allurban     = .false.
  logical,                private :: landuse_mosaicworld  = .false.

  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine landuse_setup
    use scale_process, only: &
       prc_mpistop
    implicit none

    namelist / param_landuse / &
       landuse_in_basename,          &
       landuse_in_check_coordinates, &
       landuse_out_basename,         &
       landuse_out_dtype,            &
       landuse_pft_mosaic,           &
       landuse_pft_nmax,             &
       landuse_allocean,             &
       landuse_allland,              &
       landuse_allurban,             &
       landuse_mosaicworld

    integer :: ierr
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '++++++ Module[LANDUSE] / Categ[COUPLER] / Origin[SCALElib]'

    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_landuse,iostat=ierr)
    if( ierr < 0 ) then !--- missing
       if( io_l ) write(io_fid_log,*) '*** Not found namelist. Default used.'
    elseif( ierr > 0 ) then !--- fatal error
       write(*,*) 'xxx Not appropriate names in namelist PARAM_LANDUSE. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,nml=param_landuse)

    allocate( landuse_frac_land(ia,ja) )
    allocate( landuse_frac_lake(ia,ja) )
    allocate( landuse_frac_urban(ia,ja) )
    landuse_frac_land(:,:) = 0.0_rp
    landuse_frac_lake(:,:) = 0.0_rp
    landuse_frac_urban(:,:) = 0.0_rp

    allocate( landuse_index_pft(ia,ja,landuse_pft_mosaic) )
    allocate( landuse_frac_pft(ia,ja,landuse_pft_mosaic) )
    landuse_frac_pft(:,:,:) = 0.0_rp
    landuse_frac_pft(:,:,1) = 1.0_rp ! tentative, mosaic is off
    landuse_index_pft(:,:,:) = 1      ! default

    allocate( landuse_fact_ocean(ia,ja) )
    allocate( landuse_fact_land(ia,ja) )
    allocate( landuse_fact_urban(ia,ja) )
    landuse_fact_ocean(:,:) = 0.0_rp
    landuse_fact_land(:,:) = 0.0_rp
    landuse_fact_urban(:,:) = 0.0_rp


    if    ( landuse_allocean ) then
       if( io_l ) write(io_fid_log,*) '*** Assume all grids are ocean'
       call landuse_calc_fact
    elseif( landuse_allland ) then
       if( io_l ) write(io_fid_log,*) '*** Assume all grids are land'
       landuse_frac_land(:,:) = 1.0_rp
       call landuse_calc_fact
    elseif( landuse_allurban ) then
       if( io_l ) write(io_fid_log,*) '*** Assume all grids are land'
       landuse_frac_land(:,:) = 1.0_rp
       if( io_l ) write(io_fid_log,*) '*** Assume all lands are urban'
       landuse_frac_urban(:,:) = 1.0_rp
       call landuse_calc_fact
    elseif( landuse_mosaicworld ) then
       if( io_l ) write(io_fid_log,*) '*** Assume all grids have ocean, land, and urban'
       landuse_frac_land(:,:) = 0.5_rp
       landuse_frac_urban(:,:) = 0.5_rp
       call landuse_calc_fact
    else
       ! read from file
       call landuse_read
    endif

    return
  end subroutine landuse_setup

  !-----------------------------------------------------------------------------
  subroutine landuse_calc_fact
    implicit none
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '+++ calculate landuse factor'

    ! tentative treatment: The area of the lake is treated as the ocean
    landuse_frac_land(:,:) = landuse_frac_land(:,:) * ( 1.0_rp - landuse_frac_lake(:,:) )

    ! make factors
    landuse_fact_ocean(:,:) = ( 1.0_rp - landuse_frac_land(:,:) )
    landuse_fact_land(:,:) = (          landuse_frac_land(:,:) ) * ( 1.0_rp - landuse_frac_urban(:,:) )
    landuse_fact_urban(:,:) = (          landuse_frac_land(:,:) ) * (          landuse_frac_urban(:,:) )

    return
  end subroutine landuse_calc_fact

  !-----------------------------------------------------------------------------
  subroutine landuse_read
    use scale_fileio, only: &
       fileio_open, &
       fileio_read, &
       fileio_flush, &
       fileio_check_coordinates, &
       fileio_close
    use scale_comm, only: &
       comm_vars8, &
       comm_wait
    implicit none

    real(RP) :: temp(ia,ja)

    character(len=H_SHORT) :: varname
    integer :: fid
    integer :: p, tag
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*)
    if( io_l ) write(io_fid_log,*) '*** Input landuse file ***'

    if ( landuse_in_basename /= '' ) then

       call fileio_open( fid, landuse_in_basename )

       call fileio_read( landuse_frac_land(:,:),         & ! [OUT]
                         fid, 'FRAC_LAND',  'XY', step=1 ) ! [IN]
       call fileio_read( landuse_frac_lake(:,:),         & ! [OUT]
                         fid, 'FRAC_LAKE',  'XY', step=1 ) ! [IN]
       call fileio_read( landuse_frac_urban(:,:),        & ! [OUT]
                         fid, 'FRAC_URBAN', 'XY', step=1 ) ! [IN]

       call fileio_read( landuse_fact_ocean(:,:),            & ! [OUT]
                         fid, 'FRAC_OCEAN_abs', 'XY', step=1 ) ! [IN]
       call fileio_read( landuse_fact_land(:,:),             & ! [OUT]
                         fid, 'FRAC_LAND_abs',  'XY', step=1 ) ! [IN]
       call fileio_read( landuse_fact_urban(:,:),            & ! [OUT]
                         fid, 'FRAC_URBAN_abs', 'XY', step=1 ) ! [IN]

       call fileio_flush( fid )

       if ( landuse_in_check_coordinates ) then
          call fileio_check_coordinates( fid )
       end if

       call comm_vars8( landuse_frac_land(:,:), 1 )
       call comm_vars8( landuse_frac_lake(:,:), 2 )
       call comm_vars8( landuse_frac_urban(:,:), 3 )
       call comm_vars8( landuse_fact_ocean(:,:), 4 )
       call comm_vars8( landuse_fact_land(:,:), 5 )
       call comm_vars8( landuse_fact_urban(:,:), 6 )
       call comm_wait ( landuse_frac_land(:,:), 1 )
       call comm_wait ( landuse_frac_lake(:,:), 2 )
       call comm_wait ( landuse_frac_urban(:,:), 3 )
       call comm_wait ( landuse_fact_ocean(:,:), 4 )
       call comm_wait ( landuse_fact_land(:,:), 5 )
       call comm_wait ( landuse_fact_urban(:,:), 6 )

       do p = 1, landuse_pft_mosaic
          write(varname,'(A8,I1.1)') 'FRAC_PFT', p

          call fileio_read( landuse_frac_pft(:,:,p),   & ! [OUT]
                            fid, varname, 'XY', step=1 ) ! [IN]
          call fileio_flush( fid )

          tag = 7 + (p-1)*landuse_pft_mosaic
          call comm_vars8( landuse_frac_pft(:,:,p), tag )
          call comm_wait ( landuse_frac_pft(:,:,p), tag )

          write(varname,'(A9,I1.1)') 'INDEX_PFT', p

          call fileio_read( temp(:,:),                 & ! [OUT]
                            fid, varname, 'XY', step=1 ) ! [IN]
          call fileio_flush( fid )

          tag = 8 + (p-1)*landuse_pft_mosaic
          call comm_vars8( temp(:,:), tag )
          call comm_wait ( temp(:,:), tag )

          landuse_index_pft(:,:,p) = int(temp(:,:))
       enddo

       call fileio_close( fid )

    else
       if( io_l ) write(io_fid_log,*) '*** landuse file is not specified.'
       if( io_l ) write(io_fid_log,*) '*** Assume all grids are ocean'
    endif

    return
  end subroutine landuse_read

  !-----------------------------------------------------------------------------
  subroutine landuse_write
    use scale_fileio, only: &
       fileio_create, &
       fileio_def_var, &
       fileio_enddef, &
       fileio_write_var, &
       fileio_close
    implicit none

    real(RP) :: temp(ia,ja)

    integer :: fid, vid(6+landuse_pft_mosaic*2)
    character(len=H_SHORT) :: varname
    integer :: p
    !---------------------------------------------------------------------------

    if ( landuse_out_basename /= '' ) then

       if( io_l ) write(io_fid_log,*)
       if( io_l ) write(io_fid_log,*) '*** Output landuse file ***'

       call fileio_create( fid, landuse_out_basename, landuse_out_title, &
                           landuse_out_dtype, nozcoord=.true. )

       call fileio_def_var( fid, vid(1), 'FRAC_LAND',  'LAND fraction',  '1', 'XY', landuse_out_dtype )
       call fileio_def_var( fid, vid(2), 'FRAC_LAKE',  'LAKE fraction',  '1', 'XY', landuse_out_dtype )
       call fileio_def_var( fid, vid(3), 'FRAC_URBAN', 'URBAN fraction', '1', 'XY', landuse_out_dtype )
       call fileio_def_var( fid, vid(4), 'FRAC_OCEAN_abs', 'absolute OCEAN fraction', '1', 'XY', landuse_out_dtype )
       call fileio_def_var( fid, vid(5), 'FRAC_LAND_abs',  'absolute LAND fraction',  '1', 'XY', landuse_out_dtype )
       call fileio_def_var( fid, vid(6), 'FRAC_URBAN_abs', 'absolute URBAN fraction', '1', 'XY', landuse_out_dtype )

       do p = 1, landuse_pft_mosaic
          write(varname,'(A8,I1.1)') 'FRAC_PFT', p
          call fileio_def_var( fid, vid(7+2*(p-1)), varname, 'PFT fraction', '1', 'XY', landuse_out_dtype )
          write(varname,'(A9,I1.1)') 'INDEX_PFT', p
          call fileio_def_var( fid, vid(8+2*(p-1)), varname, 'PFT index',    '1', 'XY', landuse_out_dtype )
       end do

       call fileio_enddef( fid )

       call fileio_write_var( fid, vid(1), landuse_frac_land(:,:), 'FRAC_LAND',  'XY' )
       call fileio_write_var( fid, vid(2), landuse_frac_lake(:,:), 'FRAC_LAKE',  'XY' )
       call fileio_write_var( fid, vid(3), landuse_frac_urban(:,:), 'FRAC_URBAN', 'XY' )
       call fileio_write_var( fid, vid(4), landuse_fact_ocean(:,:), 'FRAC_OCEAN_abs', 'XY' )
       call fileio_write_var( fid, vid(5), landuse_fact_land(:,:), 'FRAC_LAND_abs',  'XY' )
       call fileio_write_var( fid, vid(6), landuse_fact_urban(:,:), 'FRAC_URBAN_abs', 'XY' )

       do p = 1, landuse_pft_mosaic
          write(varname,'(A8,I1.1)') 'FRAC_PFT', p
          call fileio_write_var( fid, vid(7+2*(p-1)), landuse_frac_pft(:,:,p), varname, 'XY' )
          write(varname,'(A9,I1.1)') 'INDEX_PFT', p
          temp(:,:) = real(LANDUSE_index_PFT(:,:,p),kind=rp)
          call fileio_write_var( fid, vid(8+2*(p-1)), temp(:,:),               varname, 'XY' )
       end do

       call fileio_close( fid )

    end if

    return
  end subroutine landuse_write

end module scale_landuse