1122 lines
43 KiB
Fortran
1122 lines
43 KiB
Fortran
module surfrdMod
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !MODULE: surfrdMod
|
|
!
|
|
! !DESCRIPTION:
|
|
! Contains methods for reading in surface data file and determining
|
|
! two-dimensional subgrid weights as well as writing out new surface
|
|
! dataset. When reading in the surface dataset, determines array
|
|
! which sets the PFT for each of the [maxpatch] patches and
|
|
! array which sets the relative abundance of the PFT.
|
|
! Also fills in the PFTs for vegetated portion of each grid cell.
|
|
! Fractional areas for these points pertain to "vegetated"
|
|
! area not to total grid area. Need to adjust them for fraction of grid
|
|
! that is vegetated. Also fills in urban, lake, wetland, and glacier patches.
|
|
!
|
|
! !USES:
|
|
use shr_kind_mod, only : r8 => shr_kind_r8
|
|
use abortutils , only : endrun
|
|
use clm_varpar , only : nlevsoi, numpft, &
|
|
maxpatch_pft, numcft, maxpatch, &
|
|
npatch_urban, npatch_lake, npatch_wet, &
|
|
npatch_glacier,maxpatch_urb, npatch_glacier_mec, &
|
|
maxpatch_glcmec
|
|
use clm_varctl , only : glc_topomax, iulog, scmlat, scmlon, single_column, &
|
|
create_glacier_mec_landunit, use_cndv
|
|
use clm_varsur , only : wtxy, vegxy, topoxy, pctspec
|
|
use decompMod , only : get_proc_bounds
|
|
use clmtype
|
|
use spmdMod
|
|
use ncdio_pio , only : file_desc_t, var_desc_t, ncd_pio_openfile, ncd_pio_closefile, &
|
|
ncd_io, check_var, ncd_inqfdims, check_dim
|
|
use pio
|
|
!
|
|
! !PUBLIC TYPES:
|
|
implicit none
|
|
save
|
|
!
|
|
! !PUBLIC MEMBER FUNCTIONS:
|
|
public :: surfrd_get_globmask ! Reads global land mask (needed for setting domain decomp)
|
|
public :: surfrd_get_grid ! Read grid/ladnfrac data into domain (after domain decomp)
|
|
public :: surfrd_get_topo ! Read grid topography into domain (after domain decomp)
|
|
public :: surfrd_get_data ! Read surface dataset and determine subgrid weights
|
|
!
|
|
! !PUBLIC DATA MEMBERS:
|
|
logical, public :: crop_prog = .false. ! If prognostic crops is turned on
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein
|
|
! Updated by T Craig
|
|
! Updated by Mariana Vertenstein Jan 2011
|
|
!
|
|
!
|
|
! !PRIVATE MEMBER FUNCTIONS:
|
|
private :: surfrd_wtxy_special
|
|
private :: surfrd_wtxy_veg_all
|
|
private :: surfrd_wtxy_veg_dgvm
|
|
!EOP
|
|
!-----------------------------------------------------------------------
|
|
|
|
contains
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_get_globmask
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_get_globmask(filename, mask, ni, nj)
|
|
!
|
|
! !DESCRIPTION:
|
|
! Read the surface dataset grid related information:
|
|
! This is the first routine called by clm_initialize
|
|
! NO DOMAIN DECOMPOSITION HAS BEEN SET YET
|
|
!
|
|
! !USES:
|
|
use fileutils , only : getfil
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
character(len=*), intent(in) :: filename ! grid filename
|
|
integer , pointer :: mask(:) ! grid mask
|
|
integer , intent(out) :: ni, nj ! global grid sizes
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine surfrd in this module
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
logical :: isgrid2d
|
|
integer :: dimid,varid ! netCDF id's
|
|
integer :: ns ! size of grid on file
|
|
integer :: n,i,j ! index
|
|
integer :: ier ! error status
|
|
type(file_desc_t) :: ncid ! netcdf id
|
|
type(var_desc_t) :: vardesc ! variable descriptor
|
|
character(len=256) :: varname ! variable name
|
|
character(len=256) :: locfn ! local file name
|
|
logical :: readvar ! read variable in or not
|
|
integer , allocatable :: idata2d(:,:)
|
|
character(len=32) :: subname = 'surfrd_get_globmask' ! subroutine name
|
|
!-----------------------------------------------------------------------
|
|
|
|
if (filename == ' ') then
|
|
mask(:) = 1
|
|
RETURN
|
|
end if
|
|
|
|
if (masterproc) then
|
|
if (filename == ' ') then
|
|
write(iulog,*) trim(subname),' ERROR: filename must be specified '
|
|
call endrun()
|
|
endif
|
|
end if
|
|
|
|
call getfil( filename, locfn, 0 )
|
|
call ncd_pio_openfile (ncid, trim(locfn), 0)
|
|
|
|
! Determine dimensions and if grid file is 2d or 1d
|
|
|
|
call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns)
|
|
if (masterproc) then
|
|
write(iulog,*)'lat/lon grid flag (isgrid2d) is ',isgrid2d
|
|
end if
|
|
|
|
allocate(mask(ns))
|
|
mask(:) = 1
|
|
|
|
if (isgrid2d) then
|
|
allocate(idata2d(ni,nj))
|
|
idata2d(:,:) = 1
|
|
call ncd_io(ncid=ncid, varname='LANDMASK', data=idata2d, flag='read', readvar=readvar)
|
|
if (.not. readvar) then
|
|
call ncd_io(ncid=ncid, varname='mask', data=idata2d, flag='read', readvar=readvar)
|
|
end if
|
|
if (readvar) then
|
|
do j = 1,nj
|
|
do i = 1,ni
|
|
n = (j-1)*ni + i
|
|
mask(n) = idata2d(i,j)
|
|
enddo
|
|
enddo
|
|
end if
|
|
deallocate(idata2d)
|
|
else
|
|
call ncd_io(ncid=ncid, varname='LANDMASK', data=mask, flag='read', readvar=readvar)
|
|
if (.not. readvar) then
|
|
call ncd_io(ncid=ncid, varname='mask', data=mask, flag='read', readvar=readvar)
|
|
end if
|
|
end if
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: landmask not on fatmlndfrc file' )
|
|
|
|
call ncd_pio_closefile(ncid)
|
|
|
|
end subroutine surfrd_get_globmask
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_get_grid
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_get_grid(ldomain, filename, glcfilename)
|
|
!
|
|
! !DESCRIPTION:
|
|
! THIS IS CALLED AFTER THE DOMAIN DECOMPOSITION HAS BEEN CREATED
|
|
! Read the surface dataset grid related information:
|
|
! o real latitude of grid cell (degrees)
|
|
! o real longitude of grid cell (degrees)
|
|
!
|
|
! !USES:
|
|
use clm_varcon, only : spval, re
|
|
use domainMod , only : domain_type, domain_init, domain_clean, lon1d, lat1d
|
|
use decompMod , only : get_proc_bounds
|
|
use fileutils , only : getfil
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
type(domain_type),intent(inout) :: ldomain ! domain to init
|
|
character(len=*) ,intent(in) :: filename ! grid filename
|
|
character(len=*) ,optional, intent(in) :: glcfilename ! glc mask filename
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine surfrd in this module
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
type(file_desc_t) :: ncid ! netcdf id
|
|
type(file_desc_t) :: ncidg ! netCDF id for glcmask
|
|
type(var_desc_t) :: vardesc ! variable descriptor
|
|
integer :: beg ! local beg index
|
|
integer :: end ! local end index
|
|
integer :: ni,nj,ns ! size of grid on file
|
|
integer :: dimid,varid ! netCDF id's
|
|
integer :: start(1), count(1) ! 1d lat/lon array sections
|
|
integer :: ier,ret ! error status
|
|
logical :: readvar ! true => variable is on input file
|
|
logical :: isgrid2d ! true => file is 2d lat/lon
|
|
logical :: istype_domain ! true => input file is of type domain
|
|
real(r8), allocatable :: rdata2d(:,:) ! temporary
|
|
character(len=16) :: vname ! temporary
|
|
character(len=256):: locfn ! local file name
|
|
integer :: n ! indices
|
|
real(r8):: eps = 1.0e-12_r8 ! lat/lon error tolerance
|
|
character(len=32) :: subname = 'surfrd_get_grid' ! subroutine name
|
|
!-----------------------------------------------------------------------
|
|
|
|
if (masterproc) then
|
|
if (filename == ' ') then
|
|
write(iulog,*) trim(subname),' ERROR: filename must be specified '
|
|
call endrun()
|
|
endif
|
|
end if
|
|
|
|
call getfil( filename, locfn, 0 )
|
|
call ncd_pio_openfile (ncid, trim(locfn), 0)
|
|
|
|
! Determine dimensions
|
|
|
|
call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns)
|
|
|
|
! Determine isgrid2d flag for domain
|
|
|
|
call get_proc_bounds(beg, end)
|
|
call domain_init(ldomain, isgrid2d=isgrid2d, ni=ni, nj=nj, nbeg=beg, nend=end)
|
|
! Determine type of file - old style grid file or new style domain file
|
|
|
|
call check_var(ncid=ncid, varname='LONGXY', vardesc=vardesc, readvar=readvar)
|
|
if (readvar) istype_domain = .false.
|
|
|
|
call check_var(ncid=ncid, varname='xc', vardesc=vardesc, readvar=readvar)
|
|
if (readvar) istype_domain = .true.
|
|
|
|
! Read in area, lon, lat
|
|
|
|
if (istype_domain) then
|
|
call ncd_io(ncid=ncid, varname= 'area', flag='read', data=ldomain%area, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
! convert from radians**2 to km**2
|
|
ldomain%area = ldomain%area * (re**2)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: area NOT on file' )
|
|
|
|
call ncd_io(ncid=ncid, varname= 'xc', flag='read', data=ldomain%lonc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: xc NOT on file' )
|
|
|
|
call ncd_io(ncid=ncid, varname= 'yc', flag='read', data=ldomain%latc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: yc NOT on file' )
|
|
else
|
|
call ncd_io(ncid=ncid, varname= 'AREA', flag='read', data=ldomain%area, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: AREA NOT on file' )
|
|
|
|
call ncd_io(ncid=ncid, varname= 'LONGXY', flag='read', data=ldomain%lonc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: LONGXY NOT on file' )
|
|
|
|
call ncd_io(ncid=ncid, varname= 'LATIXY', flag='read', data=ldomain%latc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: LATIXY NOT on file' )
|
|
end if
|
|
|
|
if (isgrid2d) then
|
|
allocate(rdata2d(ni,nj), lon1d(ni), lat1d(nj))
|
|
if (istype_domain) then
|
|
vname = 'xc'
|
|
else
|
|
vname = 'LONGXY'
|
|
end if
|
|
call ncd_io(ncid=ncid, varname=trim(vname), data=rdata2d, flag='read', readvar=readvar)
|
|
lon1d(:) = rdata2d(:,1)
|
|
if (istype_domain) then
|
|
vname = 'yc'
|
|
else
|
|
vname = 'LATIXY'
|
|
end if
|
|
call ncd_io(ncid=ncid, varname=trim(vname), data=rdata2d, flag='read', readvar=readvar)
|
|
lat1d(:) = rdata2d(1,:)
|
|
deallocate(rdata2d)
|
|
end if
|
|
|
|
! Check lat limited to -90,90
|
|
|
|
if (minval(ldomain%latc) < -90.0_r8 .or. &
|
|
maxval(ldomain%latc) > 90.0_r8) then
|
|
write(iulog,*) trim(subname),' WARNING: lat/lon min/max is ', &
|
|
minval(ldomain%latc),maxval(ldomain%latc)
|
|
! call endrun( trim(subname)//' ERROR: lat is outside [-90,90]' )
|
|
! write(iulog,*) trim(subname),' Limiting lat/lon to [-90/90] from ', &
|
|
! minval(domain%latc),maxval(domain%latc)
|
|
! where (ldomain%latc < -90.0_r8) ldomain%latc = -90.0_r8
|
|
! where (ldomain%latc > 90.0_r8) ldomain%latc = 90.0_r8
|
|
endif
|
|
|
|
call ncd_io(ncid=ncid, varname='LANDMASK', flag='read', data=ldomain%mask, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) then
|
|
call ncd_io(ncid=ncid, varname='mask', flag='read', data=ldomain%mask, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) then
|
|
call endrun( trim(subname)//' ERROR: LANDMASK NOT on fracdata file' )
|
|
end if
|
|
end if
|
|
|
|
call ncd_io(ncid=ncid, varname='LANDFRAC', flag='read', data=ldomain%frac, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) then
|
|
call ncd_io(ncid=ncid, varname='frac', flag='read', data=ldomain%frac, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) then
|
|
call endrun( trim(subname)//' ERROR: LANDFRAC NOT on fracdata file' )
|
|
end if
|
|
end if
|
|
|
|
call ncd_pio_closefile(ncid)
|
|
|
|
if (present(glcfilename)) then
|
|
if (masterproc) then
|
|
if (glcfilename == ' ') then
|
|
write(iulog,*) trim(subname),' ERROR: glc filename must be specified '
|
|
call endrun()
|
|
endif
|
|
end if
|
|
call getfil( glcfilename, locfn, 0 )
|
|
call ncd_pio_openfile (ncidg, trim(locfn), 0)
|
|
|
|
ldomain%glcmask(:) = 0
|
|
call ncd_io(ncid=ncidg, varname='GLCMASK', flag='read', data=ldomain%glcmask, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: GLCMASK NOT in file' )
|
|
|
|
! Make sure the glc mask is a subset of the land mask
|
|
do n = beg,end
|
|
if (ldomain%glcmask(n)==1 .and. ldomain%mask(n)==0) then
|
|
write(iulog,*)trim(subname),&
|
|
'initialize1: landmask/glcmask mismatch'
|
|
write(iulog,*)trim(subname),&
|
|
'glc requires input where landmask = 0, gridcell index', n
|
|
call endrun()
|
|
endif
|
|
enddo
|
|
call ncd_pio_closefile(ncidg)
|
|
endif ! present(glcfilename)
|
|
|
|
end subroutine surfrd_get_grid
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_get_topo
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_get_topo(domain,filename)
|
|
!
|
|
! !DESCRIPTION:
|
|
! Read the topo dataset grid related information:
|
|
! Assume domain has already been initialized and read
|
|
!
|
|
! !USES:
|
|
use domainMod , only : domain_type
|
|
use fileutils , only : getfil
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
type(domain_type),intent(inout) :: domain ! domain to init
|
|
character(len=*) ,intent(in) :: filename ! grid filename
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine initialize
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by T Craig
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
type(file_desc_t) :: ncid ! netcdf file id
|
|
integer :: n ! indices
|
|
integer :: ni,nj,ns ! size of grid on file
|
|
integer :: dimid,varid ! netCDF id's
|
|
integer :: ier ! error status
|
|
real(r8):: eps = 1.0e-12_r8 ! lat/lon error tolerance
|
|
integer :: beg,end ! local beg,end indices
|
|
logical :: isgrid2d ! true => file is 2d lat/lon
|
|
real(r8),pointer :: lonc(:),latc(:) ! local lat/lon
|
|
character(len=256) :: locfn ! local file name
|
|
logical :: readvar ! is variable on file
|
|
character(len=32) :: subname = 'surfrd_get_topo' ! subroutine name
|
|
!-----------------------------------------------------------------------
|
|
|
|
if (masterproc) then
|
|
if (filename == ' ') then
|
|
write(iulog,*) trim(subname),' ERROR: filename must be specified '
|
|
call endrun()
|
|
else
|
|
write(iulog,*) 'Attempting to read lnd topo from flndtopo ',trim(filename)
|
|
endif
|
|
end if
|
|
|
|
call getfil( filename, locfn, 0 )
|
|
call ncd_pio_openfile (ncid, trim(locfn), 0)
|
|
call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns)
|
|
|
|
if (domain%ns /= ns) then
|
|
write(iulog,*) trim(subname),' ERROR: topo file mismatch ns',&
|
|
domain%ns,ns
|
|
call endrun()
|
|
endif
|
|
|
|
beg = domain%nbeg
|
|
end = domain%nend
|
|
|
|
allocate(latc(beg:end),lonc(beg:end))
|
|
|
|
call ncd_io(ncid=ncid, varname='LONGXY', flag='read', data=lonc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: LONGXY NOT on topodata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='LATIXY', flag='read', data=latc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: LATIXY NOT on topodata file' )
|
|
|
|
do n = beg,end
|
|
if (abs(latc(n)-domain%latc(n)) > eps .or. &
|
|
abs(lonc(n)-domain%lonc(n)) > eps) then
|
|
write(iulog,*) trim(subname),' ERROR: topo file mismatch lat,lon',latc(n),&
|
|
domain%latc(n),lonc(n),domain%lonc(n),eps
|
|
call endrun()
|
|
endif
|
|
enddo
|
|
|
|
call ncd_io(ncid=ncid, varname='TOPO', flag='read', data=domain%topo, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: TOPO NOT on topodata file' )
|
|
|
|
deallocate(latc,lonc)
|
|
|
|
call ncd_pio_closefile(ncid)
|
|
|
|
end subroutine surfrd_get_topo
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_get_data
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_get_data (ldomain, lfsurdat)
|
|
!
|
|
! !DESCRIPTION:
|
|
! Read the surface dataset and create subgrid weights.
|
|
! The model's surface dataset recognizes 6 basic land cover types within a grid
|
|
! cell: lake, wetland, urban, glacier, glacier_mec and vegetated. The vegetated
|
|
! portion of the grid cell is comprised of up to [maxpatch_pft] PFTs. These
|
|
! subgrid patches are read in explicitly for each grid cell. This is in
|
|
! contrast to LSMv1, where the PFTs were built implicitly from biome types.
|
|
! o real latitude of grid cell (degrees)
|
|
! o real longitude of grid cell (degrees)
|
|
! o integer surface type: 0 = ocean or 1 = land
|
|
! o integer soil color (1 to 20) for use with soil albedos
|
|
! o real soil texture, %sand, for thermal and hydraulic properties
|
|
! o real soil texture, %clay, for thermal and hydraulic properties
|
|
! o real % of cell covered by lake for use as subgrid patch
|
|
! o real % of cell covered by wetland for use as subgrid patch
|
|
! o real % of cell that is urban for use as subgrid patch
|
|
! o real % of cell that is glacier for use as subgrid patch
|
|
! o real % of cell that is glacier_mec for use as subgrid patch
|
|
! o integer PFTs
|
|
! o real % abundance PFTs (as a percent of vegetated area)
|
|
!
|
|
! !USES:
|
|
use clm_varctl , only : allocate_all_vegpfts, create_crop_landunit
|
|
use pftvarcon , only : noveg
|
|
use fileutils , only : getfil
|
|
use domainMod , only : domain_type, domain_init, domain_clean
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
type(domain_type),intent(in) :: ldomain ! land domain associated with wtxy
|
|
character(len=*), intent(in) :: lfsurdat ! surface dataset filename
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine initialize in module initializeMod
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein, Sam Levis and Gordon Bonan
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
type(var_desc_t) :: vardesc ! pio variable descriptor
|
|
type(domain_type) :: surfdata_domain ! local domain associated with surface dataset
|
|
character(len=256):: locfn ! local file name
|
|
integer :: n ! loop indices
|
|
integer :: ni,nj,ns ! domain sizes
|
|
character(len=16) :: lon_var, lat_var ! names of lat/lon on dataset
|
|
logical :: readvar ! true => variable is on dataset
|
|
real(r8) :: rmaxlon,rmaxlat ! local min/max vars
|
|
type(file_desc_t) :: ncid ! netcdf id
|
|
integer :: begg,endg ! beg,end gridcell indices
|
|
logical :: istype_domain ! true => input file is of type domain
|
|
logical :: isgrid2d ! true => intut grid is 2d
|
|
character(len=32) :: subname = 'surfrd_get_data' ! subroutine name
|
|
!-----------------------------------------------------------------------
|
|
|
|
if (masterproc) then
|
|
write(iulog,*) 'Attempting to read surface boundary data .....'
|
|
if (lfsurdat == ' ') then
|
|
write(iulog,*)'lfsurdat must be specified'; call endrun()
|
|
endif
|
|
endif
|
|
|
|
call get_proc_bounds(begg,endg)
|
|
allocate(pctspec(begg:endg))
|
|
|
|
vegxy(:,:) = noveg
|
|
wtxy(:,:) = 0._r8
|
|
pctspec(:) = 0._r8
|
|
if (allocated(topoxy)) topoxy(:,:) = 0._r8
|
|
|
|
! Read surface data
|
|
|
|
call getfil( lfsurdat, locfn, 0 )
|
|
call ncd_pio_openfile (ncid, trim(locfn), 0)
|
|
|
|
! Read in pft mask - this variable is only on the surface dataset - but not
|
|
! on the domain dataset
|
|
|
|
call ncd_io(ncid=ncid, varname= 'PFTDATA_MASK', flag='read', data=ldomain%pftm, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: pftm NOT on surface dataset' )
|
|
|
|
! Check if fsurdat grid is "close" to fatmlndfrc grid, exit if lats/lon > 0.001
|
|
|
|
call check_var(ncid=ncid, varname='xc', vardesc=vardesc, readvar=readvar)
|
|
if (readvar) then
|
|
istype_domain = .true.
|
|
else
|
|
call check_var(ncid=ncid, varname='LONGXY', vardesc=vardesc, readvar=readvar)
|
|
if (readvar) then
|
|
istype_domain = .false.
|
|
else
|
|
call endrun( trim(subname)//' ERROR: unknown domain type')
|
|
end if
|
|
end if
|
|
if (istype_domain) then
|
|
lon_var = 'xc'
|
|
lat_var = 'yc'
|
|
else
|
|
lon_var = 'LONGXY'
|
|
lat_var = 'LATIXY'
|
|
end if
|
|
if ( masterproc )then
|
|
write(iulog,*) trim(subname),' lon_var = ',trim(lon_var),' lat_var =',trim(lat_var)
|
|
end if
|
|
|
|
call ncd_inqfdims(ncid, isgrid2d, ni, nj, ns)
|
|
call domain_init(surfdata_domain, isgrid2d, ni, nj, begg, endg, clmlevel=grlnd)
|
|
|
|
call ncd_io(ncid=ncid, varname=lon_var, flag='read', data=surfdata_domain%lonc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: lon var NOT on surface dataset' )
|
|
|
|
call ncd_io(ncid=ncid, varname=lat_var, flag='read', data=surfdata_domain%latc, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: lat var NOT on surface dataset' )
|
|
|
|
rmaxlon = 0.0_r8
|
|
rmaxlat = 0.0_r8
|
|
do n = begg,endg
|
|
if (ldomain%lonc(n)-surfdata_domain%lonc(n) > 300.) then
|
|
rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n)-360._r8))
|
|
elseif (ldomain%lonc(n)-surfdata_domain%lonc(n) < -300.) then
|
|
rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n)+360._r8))
|
|
else
|
|
rmaxlon = max(rmaxlon,abs(ldomain%lonc(n)-surfdata_domain%lonc(n)))
|
|
endif
|
|
rmaxlat = max(rmaxlat,abs(ldomain%latc(n)-surfdata_domain%latc(n)))
|
|
enddo
|
|
if (rmaxlon > 0.001_r8 .or. rmaxlat > 0.001_r8) then
|
|
write(iulog,*) trim(subname)//': surfdata/fatmgrid lon/lat mismatch error',&
|
|
rmaxlon,rmaxlat
|
|
call endrun(trim(subname))
|
|
end if
|
|
call domain_clean(surfdata_domain)
|
|
|
|
! Obtain special landunit info
|
|
|
|
call surfrd_wtxy_special(ncid, ldomain%ns)
|
|
|
|
! Obtain vegetated landunit info
|
|
|
|
if (use_cndv) then
|
|
if (create_crop_landunit) then ! CNDV means allocate_all_vegpfts = .true.
|
|
call surfrd_wtxy_veg_all(ncid, ldomain%ns, ldomain%pftm)
|
|
end if
|
|
call surfrd_wtxy_veg_dgvm()
|
|
else
|
|
if (allocate_all_vegpfts) then
|
|
call surfrd_wtxy_veg_all(ncid, ldomain%ns, ldomain%pftm)
|
|
else
|
|
call endrun (trim(subname) // 'only allocate_all_vegpfts is supported')
|
|
end if
|
|
end if
|
|
|
|
call ncd_pio_closefile(ncid)
|
|
|
|
if ( masterproc )then
|
|
write(iulog,*) 'Successfully read surface boundary data'
|
|
write(iulog,*)
|
|
end if
|
|
|
|
end subroutine surfrd_get_data
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_wtxy_special
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_wtxy_special(ncid, ns)
|
|
!
|
|
! !DESCRIPTION:
|
|
! Determine weight with respect to gridcell of all special "pfts" as well
|
|
! as soil color and percent sand and clay
|
|
!
|
|
! !USES:
|
|
use pftvarcon , only : noveg
|
|
use UrbanInputMod , only : urbinp
|
|
use clm_varpar , only : maxpatch_glcmec
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
type(file_desc_t), intent(inout) :: ncid ! netcdf id
|
|
integer , intent(in) :: ns ! domain size
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine surfrd in this module
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein, Sam Levis and Gordon Bonan
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
integer :: n,nl,nurb,g ! indices
|
|
integer :: begg,endg ! gcell beg/end
|
|
integer :: dimid,varid ! netCDF id's
|
|
real(r8) :: nlevsoidata(nlevsoi)
|
|
logical :: found ! temporary for error check
|
|
integer :: nindx ! temporary for error check
|
|
integer :: ier ! error status
|
|
integer :: nlev ! level
|
|
integer :: npatch
|
|
logical :: readvar
|
|
real(r8),pointer :: pctgla(:) ! percent of grid cell is glacier
|
|
real(r8),pointer :: pctlak(:) ! percent of grid cell is lake
|
|
real(r8),pointer :: pctwet(:) ! percent of grid cell is wetland
|
|
real(r8),pointer :: pcturb(:) ! percent of grid cell is urbanized
|
|
real(r8),pointer :: pctglc_mec(:,:) ! percent of grid cell is glacier_mec (in each elev class)
|
|
real(r8),pointer :: pctglc_mec_tot(:) ! percent of grid cell is glacier (sum over classes)
|
|
real(r8),pointer :: topoglc_mec(:,:) ! surface elevation in each elev class
|
|
character(len=32) :: subname = 'surfrd_wtxy_special' ! subroutine name
|
|
real(r8) closelat,closelon
|
|
!!-----------------------------------------------------------------------
|
|
|
|
call get_proc_bounds(begg,endg)
|
|
|
|
allocate(pctgla(begg:endg),pctlak(begg:endg))
|
|
allocate(pctwet(begg:endg),pcturb(begg:endg))
|
|
if (create_glacier_mec_landunit) then
|
|
allocate(pctglc_mec(begg:endg,maxpatch_glcmec))
|
|
allocate(pctglc_mec_tot(begg:endg))
|
|
allocate(topoglc_mec(begg:endg,maxpatch_glcmec))
|
|
allocate(glc_topomax(0:maxpatch_glcmec))
|
|
endif
|
|
|
|
call check_dim(ncid, 'nlevsoi', nlevsoi)
|
|
|
|
! Obtain non-grid surface properties of surface dataset other than percent pft
|
|
|
|
call ncd_io(ncid=ncid, varname='PCT_WETLAND', flag='read', data=pctwet, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_WETLAND NOT on surfdata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='PCT_LAKE' , flag='read', data=pctlak, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_LAKE NOT on surfdata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='PCT_GLACIER', flag='read', data=pctgla, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_GLACIER NOT on surfdata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='PCT_URBAN' , flag='read', data=pcturb, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_URBAN NOT on surfdata file' )
|
|
|
|
if (create_glacier_mec_landunit) then ! call ncd_io_gs_int2d
|
|
|
|
call check_dim(ncid, 'nglcec', maxpatch_glcmec )
|
|
call check_dim(ncid, 'nglcecp1', maxpatch_glcmec+1 )
|
|
|
|
call ncd_io(ncid=ncid, varname='GLC_MEC', flag='read', data=glc_topomax, &
|
|
readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//'ERROR: GLC_MEC was NOT on the input surfdata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='PCT_GLC_MEC', flag='read', data=pctglc_mec, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_GLC_MEC NOT on surfdata file' )
|
|
|
|
call ncd_io(ncid=ncid, varname='TOPO_GLC_MEC', flag='read', data=topoglc_mec, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: TOPO_GLC_MEC NOT on surfdata file' )
|
|
|
|
pctglc_mec_tot(:) = 0._r8
|
|
do n = 1, maxpatch_glcmec
|
|
do nl = begg,endg
|
|
pctglc_mec_tot(nl) = pctglc_mec_tot(nl) + pctglc_mec(nl,n)
|
|
enddo
|
|
enddo
|
|
|
|
! Make sure sum of pctglc_mec = pctgla (approximately), then correct pctglc_mec so
|
|
! that its sum more exactly equals pctgla, then zero out pctgla
|
|
!
|
|
! WJS (9-28-12): The reason for the correction piece of this is: in the surface
|
|
! dataset, pctgla underwent various minor corrections that make it the trusted
|
|
! value (as opposed to sum(pctglc_mec). sum(pctglc_mec) can differ from pctgla by
|
|
! single precision roundoff. This difference can cause problems later (e.g., in the
|
|
! consistency check in pftdynMod), so we do this correction here. It might be
|
|
! better to do this correction in mksurfdata_map, but because of time constraints,
|
|
! which make me unable to recreate surface datasets, I have to do it here instead
|
|
! (and there are arguments for putting it here anyway).
|
|
|
|
do nl = begg,endg
|
|
! We need to use a fairly high threshold for equality (2.0e-5) because pctgla
|
|
! and pctglc_mec are computed using single precision inputs. Note that this
|
|
! threshold agrees with the threshold in the error checks in mkglcmecMod:
|
|
! mkglcmec in mksurfdata_map.
|
|
if (abs(pctgla(nl) - pctglc_mec_tot(nl)) > 2.0e-5) then
|
|
write(iulog,*) ' '
|
|
write(iulog,*) 'surfrd error: pctgla not equal to sum of pctglc_mec for nl=', nl
|
|
write(iulog,*) 'pctgla =', pctgla(nl)
|
|
write(iulog,*) 'pctglc_mec_tot =', pctglc_mec_tot(nl)
|
|
call endrun()
|
|
endif
|
|
|
|
! Correct the remaining minor differences in pctglc_mec so sum more exactly
|
|
! equals pctglc (see notes above for justification)
|
|
if (pctglc_mec_tot(nl) > 0.0_r8) then
|
|
pctglc_mec(nl,:) = pctglc_mec(nl,:) * pctgla(nl)/pctglc_mec_tot(nl)
|
|
end if
|
|
|
|
! Now recompute pctglc_mec_tot, and confirm that we are now much closer to pctgla
|
|
pctglc_mec_tot(nl) = 0._r8
|
|
do n = 1, maxpatch_glcmec
|
|
pctglc_mec_tot(nl) = pctglc_mec_tot(nl) + pctglc_mec(nl,n)
|
|
end do
|
|
|
|
if (abs(pctgla(nl) - pctglc_mec_tot(nl)) > 1.0e-13) then
|
|
write(iulog,*) ' '
|
|
write(iulog,*) 'surfrd error: after correction, pctgla not equal to sum of pctglc_mec for nl=', nl
|
|
write(iulog,*) 'pctgla =', pctgla(nl)
|
|
write(iulog,*) 'pctglc_mec_tot =', pctglc_mec_tot(nl)
|
|
call endrun()
|
|
endif
|
|
|
|
! Finally, zero out pctgla
|
|
pctgla(nl) = 0._r8
|
|
enddo
|
|
|
|
! If pctglc_mec_tot is very close to 100%, round to 100%
|
|
|
|
do nl = begg,endg
|
|
! The inequality here ( <= 2.0e-5 ) is designed to be the complement of the
|
|
! above check that makes sure pctglc_mec_tot is close to pctgla: so if pctglc=
|
|
! 100 (exactly), then exactly one of these conditionals will be triggered.
|
|
! Update 9-28-12: Now that there is a rescaling of pctglc_mec to bring it more
|
|
! in line with pctgla, we could probably decrease this tolerance again (the
|
|
! point about exactly one of these conditionals being triggered no longer holds)
|
|
! - or perhaps even get rid of this whole block of code. But I'm keeping this as
|
|
! is for now because that's how I tested it, and I don't think it will hurt
|
|
! anything to use this larger tolerance.
|
|
if (abs(pctglc_mec_tot(nl) - 100._r8) <= 2.0e-5) then
|
|
pctglc_mec(nl,:) = pctglc_mec(nl,:) * 100._r8 / pctglc_mec_tot(nl)
|
|
pctglc_mec_tot(nl) = 100._r8
|
|
endif
|
|
enddo
|
|
|
|
pctspec = pctwet + pctlak + pcturb + pctglc_mec_tot
|
|
|
|
if ( masterproc ) write(iulog,*) ' elevation limits = ', glc_topomax
|
|
|
|
else
|
|
|
|
pctspec = pctwet + pctlak + pcturb + pctgla
|
|
|
|
endif
|
|
|
|
! Error check: glacier, lake, wetland, urban sum must be less than 100
|
|
|
|
found = .false.
|
|
do nl = begg,endg
|
|
if (pctspec(nl) > 100._r8+1.e-04_r8) then
|
|
found = .true.
|
|
nindx = nl
|
|
exit
|
|
end if
|
|
if (found) exit
|
|
end do
|
|
if ( found ) then
|
|
write(iulog,*)'surfrd error: PFT cover>100 for nl=',nindx
|
|
call endrun()
|
|
end if
|
|
|
|
! Determine veg and wtxy for special landunits
|
|
|
|
do nl = begg,endg
|
|
|
|
vegxy(nl,npatch_lake) = noveg
|
|
wtxy(nl,npatch_lake) = pctlak(nl)/100._r8
|
|
|
|
vegxy(nl,npatch_wet) = noveg
|
|
wtxy(nl,npatch_wet) = pctwet(nl)/100._r8
|
|
|
|
vegxy(nl,npatch_glacier)= noveg
|
|
wtxy(nl,npatch_glacier) = pctgla(nl)/100._r8
|
|
|
|
! Initialize urban weights
|
|
|
|
do nurb = npatch_urban, npatch_lake-1
|
|
vegxy(nl,nurb) = noveg
|
|
wtxy(nl,nurb) = pcturb(nl) / 100._r8
|
|
end do
|
|
if ( pcturb(nl) > 0.0_r8 )then
|
|
wtxy(nl,npatch_urban) = wtxy(nl,npatch_urban)*urbinp%wtlunit_roof(nl)
|
|
wtxy(nl,npatch_urban+1) = wtxy(nl,npatch_urban+1)*(1 - urbinp%wtlunit_roof(nl))/3
|
|
wtxy(nl,npatch_urban+2) = wtxy(nl,npatch_urban+2)*(1 - urbinp%wtlunit_roof(nl))/3
|
|
wtxy(nl,npatch_urban+3) = wtxy(nl,npatch_urban+3)*(1 - urbinp%wtlunit_roof(nl))/3 * (1.-urbinp%wtroad_perv(nl))
|
|
wtxy(nl,npatch_urban+4) = wtxy(nl,npatch_urban+4)*(1 - urbinp%wtlunit_roof(nl))/3 * urbinp%wtroad_perv(nl)
|
|
end if
|
|
|
|
end do
|
|
|
|
! Check to make sure we have valid urban data for each urban patch
|
|
|
|
found = .false.
|
|
do nl = begg,endg
|
|
if ( pcturb(nl) > 0.0_r8 )then
|
|
if (urbinp%canyon_hwr(nl) .le. 0._r8 .or. &
|
|
urbinp%em_improad(nl) .le. 0._r8 .or. &
|
|
urbinp%em_perroad(nl) .le. 0._r8 .or. &
|
|
urbinp%em_roof(nl) .le. 0._r8 .or. &
|
|
urbinp%em_wall(nl) .le. 0._r8 .or. &
|
|
urbinp%ht_roof(nl) .le. 0._r8 .or. &
|
|
urbinp%thick_roof(nl) .le. 0._r8 .or. &
|
|
urbinp%thick_wall(nl) .le. 0._r8 .or. &
|
|
urbinp%t_building_max(nl) .le. 0._r8 .or. &
|
|
urbinp%t_building_min(nl) .le. 0._r8 .or. &
|
|
urbinp%wind_hgt_canyon(nl) .le. 0._r8 .or. &
|
|
urbinp%wtlunit_roof(nl) .le. 0._r8 .or. &
|
|
urbinp%wtroad_perv(nl) .le. 0._r8 .or. &
|
|
any(urbinp%alb_improad_dir(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_improad_dif(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_perroad_dir(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_perroad_dif(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_roof_dir(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_roof_dif(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_wall_dir(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%alb_wall_dif(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%tk_roof(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%tk_wall(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%cv_roof(nl,:) .le. 0._r8) .or. &
|
|
any(urbinp%cv_wall(nl,:) .le. 0._r8)) then
|
|
found = .true.
|
|
nindx = nl
|
|
exit
|
|
else
|
|
if (urbinp%nlev_improad(nl) .gt. 0) then
|
|
nlev = urbinp%nlev_improad(nl)
|
|
if (any(urbinp%tk_improad(nl,1:nlev) .le. 0._r8) .or. &
|
|
any(urbinp%cv_improad(nl,1:nlev) .le. 0._r8)) then
|
|
found = .true.
|
|
nindx = nl
|
|
exit
|
|
end if
|
|
end if
|
|
end if
|
|
if (found) exit
|
|
end if
|
|
end do
|
|
if ( found ) then
|
|
write(iulog,*)'surfrd error: no valid urban data for nl=',nindx
|
|
write(iulog,*)'canyon_hwr: ',urbinp%canyon_hwr(nindx)
|
|
write(iulog,*)'em_improad: ',urbinp%em_improad(nindx)
|
|
write(iulog,*)'em_perroad: ',urbinp%em_perroad(nindx)
|
|
write(iulog,*)'em_roof: ',urbinp%em_roof(nindx)
|
|
write(iulog,*)'em_wall: ',urbinp%em_wall(nindx)
|
|
write(iulog,*)'ht_roof: ',urbinp%ht_roof(nindx)
|
|
write(iulog,*)'thick_roof: ',urbinp%thick_roof(nindx)
|
|
write(iulog,*)'thick_wall: ',urbinp%thick_wall(nindx)
|
|
write(iulog,*)'t_building_max: ',urbinp%t_building_max(nindx)
|
|
write(iulog,*)'t_building_min: ',urbinp%t_building_min(nindx)
|
|
write(iulog,*)'wind_hgt_canyon: ',urbinp%wind_hgt_canyon(nindx)
|
|
write(iulog,*)'wtlunit_roof: ',urbinp%wtlunit_roof(nindx)
|
|
write(iulog,*)'wtroad_perv: ',urbinp%wtroad_perv(nindx)
|
|
write(iulog,*)'alb_improad_dir: ',urbinp%alb_improad_dir(nindx,:)
|
|
write(iulog,*)'alb_improad_dif: ',urbinp%alb_improad_dif(nindx,:)
|
|
write(iulog,*)'alb_perroad_dir: ',urbinp%alb_perroad_dir(nindx,:)
|
|
write(iulog,*)'alb_perroad_dif: ',urbinp%alb_perroad_dif(nindx,:)
|
|
write(iulog,*)'alb_roof_dir: ',urbinp%alb_roof_dir(nindx,:)
|
|
write(iulog,*)'alb_roof_dif: ',urbinp%alb_roof_dif(nindx,:)
|
|
write(iulog,*)'alb_wall_dir: ',urbinp%alb_wall_dir(nindx,:)
|
|
write(iulog,*)'alb_wall_dif: ',urbinp%alb_wall_dif(nindx,:)
|
|
write(iulog,*)'tk_roof: ',urbinp%tk_roof(nindx,:)
|
|
write(iulog,*)'tk_wall: ',urbinp%tk_wall(nindx,:)
|
|
write(iulog,*)'cv_roof: ',urbinp%cv_roof(nindx,:)
|
|
write(iulog,*)'cv_wall: ',urbinp%cv_wall(nindx,:)
|
|
if (urbinp%nlev_improad(nindx) .gt. 0) then
|
|
nlev = urbinp%nlev_improad(nindx)
|
|
write(iulog,*)'tk_improad: ',urbinp%tk_improad(nindx,1:nlev)
|
|
write(iulog,*)'cv_improad: ',urbinp%cv_improad(nindx,1:nlev)
|
|
end if
|
|
call endrun()
|
|
end if
|
|
|
|
! Initialize glacier_mec weights
|
|
|
|
if (create_glacier_mec_landunit) then
|
|
do n = 1, maxpatch_glcmec
|
|
npatch = npatch_glacier_mec - maxpatch_glcmec + n
|
|
do nl = begg, endg
|
|
vegxy (nl,npatch) = noveg
|
|
wtxy (nl,npatch) = pctglc_mec(nl,n)/100._r8
|
|
topoxy(nl,npatch) = topoglc_mec(nl,n)
|
|
enddo ! nl
|
|
enddo ! maxpatch_glcmec
|
|
deallocate(pctglc_mec, pctglc_mec_tot, topoglc_mec)
|
|
endif ! create_glacier_mec_landunit
|
|
|
|
deallocate(pctgla,pctlak,pctwet,pcturb)
|
|
|
|
end subroutine surfrd_wtxy_special
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_wtxy_veg_all
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_wtxy_veg_all(ncid, ns, pftm)
|
|
!
|
|
! !DESCRIPTION:
|
|
! Determine wtxy and veg arrays for non-dynamic landuse mode
|
|
!
|
|
! !USES:
|
|
use clm_varctl , only : create_crop_landunit
|
|
use pftvarcon , only : nirrig, npcropmin
|
|
use spmdMod , only : mpicom, MPI_LOGICAL, MPI_LOR
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
type(file_desc_t),intent(inout) :: ncid ! netcdf id
|
|
integer ,intent(in) :: ns ! domain size
|
|
integer ,pointer :: pftm(:)
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine surfrd in this module
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein, Sam Levis and Gordon Bonan
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
integer :: m,mp7,mp8,mp11,n,nl ! indices
|
|
integer :: begg,endg ! beg/end gcell index
|
|
integer :: dimid,varid ! netCDF id's
|
|
integer :: ier ! error status
|
|
logical :: readvar ! is variable on dataset
|
|
real(r8) :: sumpct ! sum of %pft over maxpatch_pft
|
|
real(r8),allocatable :: pctpft(:,:) ! percent of vegetated gridcell area for PFTs
|
|
real(r8),pointer :: arrayl(:,:) ! local array
|
|
real(r8) :: numpftp1data(0:numpft)
|
|
logical :: crop = .false. ! if crop data on this section of file
|
|
character(len=32) :: subname = 'surfrd_wtxy_veg_all' ! subroutine name
|
|
!-----------------------------------------------------------------------
|
|
|
|
call get_proc_bounds(begg,endg)
|
|
allocate(pctpft(begg:endg,0:numpft))
|
|
|
|
call check_dim(ncid, 'lsmpft', numpft+1)
|
|
|
|
allocate(arrayl(begg:endg,0:numpft))
|
|
call ncd_io(ncid=ncid, varname='PCT_PFT', flag='read', data=arrayl, &
|
|
dim1name=grlnd, readvar=readvar)
|
|
if (.not. readvar) call endrun( trim(subname)//' ERROR: PCT_PFT NOT on surfdata file' )
|
|
pctpft(begg:endg,0:numpft) = arrayl(begg:endg,0:numpft)
|
|
deallocate(arrayl)
|
|
|
|
do nl = begg,endg
|
|
if (pftm(nl) >= 0) then
|
|
|
|
! Error check: make sure PFTs sum to 100% cover for vegetated landunit
|
|
! (convert pctpft from percent with respect to gridcel to percent with
|
|
! respect to vegetated landunit)
|
|
|
|
if (pctspec(nl) < 100._r8) then
|
|
sumpct = 0._r8
|
|
do m = 0,numpft
|
|
sumpct = sumpct + pctpft(nl,m) * 100._r8/(100._r8-pctspec(nl))
|
|
if (m == nirrig .and. .not. create_crop_landunit) then
|
|
if (pctpft(nl,m) > 0._r8) then
|
|
call endrun( trim(subname)//' ERROR surfrdMod: irrigated crop'// &
|
|
' PFT requires create_crop_landunit=.true.' )
|
|
end if
|
|
end if
|
|
end do
|
|
if (abs(sumpct - 100._r8) > 0.1e-4_r8) then
|
|
write(iulog,*) trim(subname)//' ERROR: sum(pct) over numpft+1 is not = 100.'
|
|
write(iulog,*) sumpct, sumpct-100._r8, nl
|
|
call endrun()
|
|
end if
|
|
if (sumpct < -0.000001_r8) then
|
|
write(iulog,*) trim(subname)//' ERROR: sum(pct) over numpft+1 is < 0.'
|
|
write(iulog,*) sumpct, nl
|
|
call endrun()
|
|
end if
|
|
do m = npcropmin, numpft
|
|
if ( pctpft(nl,m) > 0.0_r8 ) crop = .true.
|
|
end do
|
|
end if
|
|
|
|
! Set weight of each pft wrt gridcell (note that maxpatch_pft = numpft+1 here)
|
|
|
|
do m = 1,numpft+1
|
|
vegxy(nl,m) = m - 1 ! 0 (bare ground) to numpft
|
|
wtxy(nl,m) = pctpft(nl,m-1) / 100._r8
|
|
end do
|
|
|
|
end if
|
|
end do
|
|
call mpi_allreduce(crop,crop_prog,1,MPI_LOGICAL,MPI_LOR,mpicom,ier)
|
|
if (ier /= 0) then
|
|
write(iulog,*) trim(subname)//' mpi_allreduce error = ',ier
|
|
call endrun( trim(subname)//' ERROR: error in reduce of crop_prog' )
|
|
endif
|
|
if (crop_prog .and. .not. create_crop_landunit) then
|
|
call endrun( trim(subname)//' ERROR: prognostic crop '// &
|
|
'PFTs requires create_crop_landunit=.true.' )
|
|
end if
|
|
|
|
deallocate(pctpft)
|
|
|
|
end subroutine surfrd_wtxy_veg_all
|
|
|
|
!-----------------------------------------------------------------------
|
|
!BOP
|
|
!
|
|
! !IROUTINE: surfrd_wtxy_veg_dgvm
|
|
!
|
|
! !INTERFACE:
|
|
subroutine surfrd_wtxy_veg_dgvm()
|
|
!
|
|
! !DESCRIPTION:
|
|
! Determine wtxy and vegxy for CNDV mode.
|
|
!
|
|
! !USES:
|
|
use pftvarcon , only : noveg, crop
|
|
use clm_varctl, only : create_crop_landunit
|
|
!
|
|
! !ARGUMENTS:
|
|
implicit none
|
|
!
|
|
! !CALLED FROM:
|
|
! subroutine surfrd in this module
|
|
!
|
|
!
|
|
! !REVISION HISTORY:
|
|
! Created by Mariana Vertenstein 12/04
|
|
!
|
|
!
|
|
! !LOCAL VARIABLES:
|
|
!EOP
|
|
integer :: m,nl ! indices
|
|
integer :: begg,endg ! beg/end gcell index
|
|
!-----------------------------------------------------------------------
|
|
|
|
call get_proc_bounds(begg,endg)
|
|
do nl = begg,endg
|
|
do m = 1, maxpatch_pft ! CNDV means allocate_all_vegpfts = .true.
|
|
if (create_crop_landunit) then ! been through surfrd_wtxy_veg_all
|
|
if (crop(m-1) == 0) then ! so update natural vegetation only
|
|
wtxy(nl,m) = 0._r8 ! crops should have values >= 0.
|
|
end if
|
|
else ! not been through surfrd_wtxy_veg_all
|
|
wtxy(nl,m) = 0._r8 ! so update all vegetation
|
|
vegxy(nl,m) = m - 1 ! 0 (bare ground) to maxpatch_pft-1 (= 16)
|
|
end if
|
|
end do
|
|
! bare ground weights
|
|
wtxy(nl,noveg+1) = max(0._r8, 1._r8 - sum(wtxy(nl,:)))
|
|
if (abs(sum(wtxy(nl,:)) - 1._r8) > 1.e-5_r8) then
|
|
write(iulog,*) 'all wtxy =', wtxy(nl,:)
|
|
call endrun()
|
|
end if ! error check
|
|
end do
|
|
|
|
end subroutine surfrd_wtxy_veg_dgvm
|
|
|
|
end module surfrdMod
|