program Pot_to_pft  !  Version 1.0

!

! This is a program to create a Potential vegetation CLM3.0 PFT dataset that is

! compatible with the original present day dataset released with the model.  

! This program uses existing data from the half degree CLM input PFT dataset,

! in addition, it uses the Ramankutty and Foley (1999) dataset to fill in gaps 

! where the current dataset has Agriculture land cover.

!

! 1.  Check the CLM 0.5 degree source dataset to see if it has a human land cover

!      If not cell properties remain unaltered

!

! 2.  Aggregate the R&F 5 minute data into half degree grid cell by percentage of

!     potential vegetation classes (summing individual 5 minute grids)

!

! 3.  To convert the relative areas of potential vegetation to CLM PFT

!     types by doing the following translations

!

!     R&F    Name                    CLM class

!     6    Needleleaf evergreen  ---> climate rules (sub 1)  1 - temperate 

!     4                                                      2 - boreal 

!     (8) portion to 1 - temperate if rules apply

!--------------------------------------------------------------------------

!     7    Needleleaf deciduous  --->                        3 - boreal  

!--------------------------------------------------------------------------

!     1    Broadleaf evergreen   ---> climate rules (sub 2)  4 - tropical                                           temperate 

!     3                                                      5 - temperate

!--------------------------------------------------------------------------

!     2    Broadleaf deciduous   ---> climate rules (sub 3)  6 - tropical                                                      temperate 

!     5                                                      7 - temperate

!     (8)  portion to 7 - temperate if rules apply           8 - boreal 

!--------------------------------------------------------------------------

!     11   Shrub                 ---> climate rules (sub 4)  9 - temperate/evergreen  

!     12                                                     10 - temperate/deciduous

!                                                            11 - boreal/deciduous

!--------------------------------------------------------------------------

!     9    savanna               ---> climate rules (sub 5)  12 - C3 Arctic                                          temperate 

!     10   grassland                                         13 - C3

!                                                            14 - C4

!--------------------------------------------------------------------------

!     13   Tundra - assume properties of adjoining grid cells and/or current CLM cell

!--------------------------------------------------------------------------

!     14   Desert - assume properties of adjoining grid cells and/or current CLM cell

!--------------------------------------------------------------------------

!     15   Barren/ice/rock - assume properties of adjoining grid cells and/or current CLM cell

!--------------------------------------------------------------------------

!

! 4.  Check on the agreement between R&F and CLM

!     If close then fill out with CLM if not adjust PFTs to within 20 % of R&F estimates

!     Check 1 -- PFT compatibility  a) this grid cell

!                                   b) surrounding grid cell Natural PFTs types

!     Check 2 -- percentages of surrounding CLM < 15% Ag grids, and R&F

!     If not resolved and Ag>85% then use R&F

!     If not resolved and Ag<85% take average weighting of R&F by type and 50% of cell weights

!

!

! by Johannes Feddema
!    Department of Geography
!    University of Kansas
!    Lawrence, KS 66049

!

  implicit none

!

! dimensions - basic parameters first

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: nlon = 720    !input grid : longitude points

  integer, parameter :: nlat = 360    !input grid : latitude  points

  integer, parameter :: numpft = 16    !number of CLM land cover classes

  integer, parameter :: numpot = 15    !number of R&F potential veg classes

!

!  dimension arrays to use

!

!  potential data

!  

  integer :: pot_in(4320,2160)         ! Ramankutty and Foley pot veg input file

!

!  1 = Tropcal evergreen forest

!  2 = Tropical deciduous forest

!  3 = Temperate broadleaf evergreen

!  4 = Temperate needleleaf evergreen

!  5 = Temperate deciduous forest

!  6 = Boreal evergreen

!  7 = Boreal deciduous

!  8 = Evergreen deciduous mixed forest

!  9 = Savanna

!  10= Grassland

!  11= Dense Shrub

!  12= Open Shrubland

!  13= Tundra

!  14= Desert

!  15= Barren/rock/ice

!

  real(r8) :: pot_veg_core(numpot)       ! ramankutty and Foley pot veg in cell

  real(r8) :: pot_veg_rad1(numpot)       ! ramankutty and Foley pot veg in 1st ring

  real(r8) :: pot_veg_rad2(numpot)       ! ramankutty and Foley pot veg in second ring

  real(r8) :: pot_veg(numpot)            ! ramankutty and Foley pot veg work array

!

  real(r8) :: t(721,361,12)  ! Legates and Willmott air temp

  real(r8) :: p(721,361,12)  ! Legates and Willmott prec

  real(r8) :: temp(12)       ! interpolated temperature  (grids are offset by 0.25 degrees)

  real(r8) :: prec(12)       ! interpolated precipitation

  real(r8) :: clim(nlon,nlat,6)

  integer :: clim2(nlon,nlat)

!

! NCAR data

!

  real(r8) :: landmask(nlon,nlat)

  real(r8) :: pct_pft_in(nlon,nlat,0:numpft) !percent pft in each grid cell

  real(r8) :: pct_pft_out(nlon,nlat,0:numpft) !percent pft in each grid cell

!

!  0 = bare

!  1 = needle leaf evergreen - temperate

!  2 = needle leaf evergreen - boreal

!  3 = needle leaf deciduous - boreal

!  4 = broadleaf evergreen tree - tropical

!  5 = broadleaf evergreen tree - temperate

!  6 = broadleaf deciduous tree - tropical

!  7 = broadleaf deciduous tree - temperate

!  8 = broadleaf deciduous tree - boreal

!  9 = broadleaf evergreen shrub - temperate

!  10= broadleaf deciduous shrub - temperate

!  11= broadleaf deciduous shrub - boreal

!  12= C3 arctic grass

!  13= C3 grass

!  14= C4 grass

!  15= crop

!  16= crop 2 !!  Not used

!

  real(r8) :: clm_pot_core(0:numpft)       ! R&F converted to CLM veg in cell

  real(r8) :: clm_pot_rad1(0:numpft)       ! R&F converted to CLM veg in 1st ring

  real(r8) :: clm_pot_rad2(0:numpft)       ! R&F converted to CLM pot veg in second ring

  real(r8) :: clm_pot_c(0:numpft)          ! R&F converted to CLM veg in cell

  real(r8) :: clm_pot_r1(0:numpft)         ! R&F converted to CLM veg in 1st ring

  real(r8) :: clm_pot_r2(0:numpft)         ! R&F converted to CLM pot veg in second ring

!

  real(r8) :: clm_pft_core(0:numpft)       ! Ramankutty and Foley estimate CLM veg

  real(r8) :: clm_pft_rad1(0:numpft)       ! Ramankutty and Foley estimate CLM veg

  real(r8) :: clm_pft_rad2(0:numpft)       ! Ramankutty and Foley estimate CLM veg

  real(r8) :: clm_pft_r1(0:numpft)         ! Ramankutty and Foley estimate CLM veg

  real(r8) :: clm_pft_r2(0:numpft)         ! Ramankutty and Foley estimate CLM veg

!

  real(r8) :: clm_pot(0:numpft)       ! block averaged potential veg (clm types)

  real(r8) :: clm_pft(0:numpft)       ! block averaged clm veg (clm types)

  real(r8) :: clm_pft_out(0:numpft)   ! output values at the grid cell

  real(r8) :: test(0:numpft)   ! output values at the grid cell

!

  real(r8) :: lat       ! latitude of the grid cell

  real(r8) :: lon       ! longitude of the grid cell

  integer :: clm_flag ! flag to indicate completeness of surrounding CLM data

  integer :: pot_flag ! flag to indicate completeness of surrounding RF data

!

!  climate info

!

  real(r8) :: T_min           ! minimum monthly temperature 

  real(r8) :: T_max           ! maximum monthly temperature 

  real(r8) :: P_ann           ! annual total precipitation 

  real(r8) :: P_min           ! minimum monthly precipitation 

  real(r8) :: P_win           ! winter total precipitation 

  real(r8) :: GDD             ! annual total growing degrees days 

  integer :: T22_wet      ! flag to see if month > 22 have more than 25 mm Prec 1=true

  integer :: pft          ! index value 

!

  integer :: i

  integer :: j

  integer :: k

  integer :: l

  integer :: m

  integer :: file

  integer :: flag

!

!  Function declaration

!

  integer :: Grass_clim_rule

!

  real(r8) :: sum_pft

  real(r8) :: sumtest_pft

  real(r8) :: veg_diff

!

  character*6 :: dummy

!

! Open the files climatology, CLM pfts and potential vegetation

!

  open(10,file = 'input/air_t')

  open(11,file = 'input/meas_precip')

  open(12,file = 'input/pft-igbp.5x.5')

  open(13,file = 'input/rf_pot_5min.asc')

!

! open output NCAR file

!

  open(14,file = 'output/pft-pot.5x.5')

!

! read in temp and precip data

!

  do i= 1, 721

    do j= 1,361

      read(10,'(14x,12f5.1)')(t(i,j,l),l=1,12)

      read(11,'(14x,12f5.0)')(p(i,j,l),l=1,12)

    enddo

  enddo

  write(6,*)'done climatology'

!

! read over the GIS header info and write GIS header for output file

!

  do i=1,6

    read(13,'(A14)')dummy

  enddo

!

! Read in potential vegetation information

!

  do i=1,2160

    read(13,*)(pot_in(l,i),l=1,4320)

    do k=1,4320

      if(pot_in(k,i).eq.7.and.i.gt.1080)then    !  change the only SH cell of BDT to Tundra

	pot_in(k,i)=13

      endif

    enddo

  enddo

  write(6,*)'done potential veg data'

!

!  Read in NCAR data

!

  do j=nlat,1,-1

    do i=1,nlon

!

!  read landmask and pft info

!

     read (12,*) landmask(i,j),(pct_pft_in(i,j,m),m=0,numpft)

     if (landmask(i,j) == 100.) landmask(i,j) = 1.

!

    enddo

  enddo

!

!  process the data

!

  do i = 1,nlat

    do j = 1,nlon

! 

!  get latitude and longitude 

! 

      lat = 90.0 - (real(i-1) * 0.5 + 0.25)

      lon = -180.0 + (real(j-1) * 0.5 + 0.25)

!

!  check to see if the grid cell has agriculture and if it needs to be altered

!

      if(pct_pft_in(j,i,15).gt.0.)then

!

!  Below 15% ag use the core cell information only, from 15 to 30% ag use info from 

!  25 surrounding CLM grid cells and for more than 30% ag use R&F as additional info

!      use a sliding scale to increase the R&F contribution up to 80%

!  see subroutine compare for more information

!

!  aggregate the present day CLM statistics

!

       call clm_aggregate(j,i,landmask,pct_pft_in,clm_pft_core,clm_pft_r1,clm_pft_r2,clm_flag)

!

!  adjust so all three arrays have the same bare ground fraction as the core cell

!

       if(clm_flag.eq.1 .or. clm_flag.eq.4 .or. clm_flag.ge.6)then

        call bare_adjust(clm_pft_r1, pct_pft_in(j,i,0), clm_pft_rad1)

       endif

       if(clm_flag.eq.3 .or. clm_flag.ge.5)then

        call bare_adjust(clm_pft_r2, pct_pft_in(j,i,0), clm_pft_rad2)

       endif

!

!  aggragate the potential vegetation information

!

       call RF_aggregate(j,i,pot_in,pot_veg_core,pot_veg_rad1,pot_veg_rad2,pot_flag)

!

!  get the appropriate climate data - interpolate from LW

! 

       do l=1,12

         temp(l) = (t(j,i,l) + t((j+1),i,l) + t((j+1),(i+1),l) + t(j,(i+1),l)) / 4.0

         prec(l) = (p(j,i,l) + p((j+1),i,l) + p((j+1),(i+1),l) + p(j,(i+1),l)) / 4.0

       enddo

!

!  convert R&F to CLM, use climate rules and adjust arrays to have same bare 

!  fraction as core cell

!

       if(pot_flag.eq.1 .or. pot_flag.eq.4 .or. pot_flag.eq.5 .or. pot_flag.eq.7)then

        call pot_to_clm (pot_veg_core,temp,prec,lat,clm_pot_c)

        call bare_adjust(clm_pot_c, pct_pft_in(j,i,0), clm_pot_core)

       endif

!

       if(pot_flag.eq.2 .or. pot_flag.eq.4 .or. pot_flag.ge.6)then

        call pot_to_clm (pot_veg_rad1,temp,prec,lat,clm_pot_r1)

        call bare_adjust(clm_pot_r1, pct_pft_in(j,i,0), clm_pot_rad1)

       endif

!

       if(pot_flag.eq.3 .or. pot_flag.ge.5)then

        call pot_to_clm (pot_veg_rad2,temp,prec,lat,clm_pot_r2)

        call bare_adjust(clm_pot_r2, pct_pft_in(j,i,0), clm_pot_rad2)

       endif

!

       do l=0,numpft
  ! start potential loop
! 

! calculate weighted average POTENTIAL vegetation for 25 cell block to make sure

! a number of PFTs are represented 

!

         if(pot_flag.eq.1)then

!

!  island - core only   --- ignore 0 case until later

!

          clm_pot(l) = clm_pot_core(l)

!

         elseif(pot_flag.eq.2)then

!

!  first ring only has info

!

          clm_pot(l) = clm_pot_rad1(l)

!

         elseif(pot_flag.eq.3)then

! 

!  second ring only has info

!

          clm_pot(l) = clm_pot_rad2(l)

!

         elseif(pot_flag.eq.4)then

!

!  core and inner ring only

!

          clm_pot(l) = 0.667 * clm_pot_core(l) + 0.333 * clm_pot_rad1(l)

!

         elseif(pot_flag.eq.5)then

!

!  core and outer ring only

!

          clm_pot(l) = 0.833 * clm_pot_core(l) + 0.167 * clm_pot_rad2(l)

!

         elseif(pot_flag.eq.6)then

! 

!  both rings

!

          clm_pot(l) = 0.667 * clm_pot_rad1(l) + 0.333 * clm_pot_rad2(l)

!

         elseif(pot_flag.eq.7)then

! 

!  all cells have information

!

          clm_pot(l) = 0.5 * clm_pot_core(l) + 0.333 * clm_pot_rad1(l) +      &

	                  0.167 * clm_pot_rad2(l)

!

         endif

! 

! calculate weighted average PRESENT DAY CLM vegetation for 25 cell block to make sure

! a number of PFTs are represented 

!

         if(clm_flag.eq.1)then

!

!  island - core only   --- ignore 0 case until later

!

          clm_pft(l) = clm_pft_core(l)

!

         elseif(clm_flag.eq.2)then

!

!  first ring only has info

!

          clm_pft(l) = clm_pft_rad1(l) 

!

         elseif(clm_flag.eq.3)then

!

!  second ring only has info

!

          clm_pft(l) = clm_pft_rad2(l) 

!

         elseif(clm_flag.eq.4)then

!

!  core and first ring only

!

          clm_pft(l) = 0.667 * clm_pft_core(l) + 0.333 * clm_pft_rad1(l) 

!

         elseif(clm_flag.eq.5)then

!

!  core and second ring only

!

          clm_pft(l) = 0.833 * clm_pft_core(l) + 0.167 * clm_pft_rad2(l) 

!

         elseif(clm_flag.eq.6)then

! 

!  rings only

!

          clm_pft(l) = 0.667 * clm_pft_rad1(l) + 0.333 * clm_pft_rad2(l) 

!

         elseif(clm_flag.eq.7)then

!

!  all info available

!

          clm_pft(l) = 0.5 * clm_pft_core(l) + 0.333 * clm_pft_rad1(l) +      &

	                  0.167 * clm_pft_rad2(l) 

!

         endif

!

       enddo
  ! end potential loop
!

!  compare the present CLM with potential if Potential info is available

!

       if(pot_flag.gt.0)then

        call compare_pft(clm_pot,clm_pft_core,clm_pft,temp,prec,lat,clm_pft_out)

       else

        if(clm_flag.gt.0)then

!

!  if CLM data is available use that to fill in the gaps

!

         do k =1,numpft

           clm_pft_out(k) = (100.0 - clm_pft(0)) *  &

            	            clm_pft(k) / (100.0 - clm_pft(0) - clm_pft(15))

         enddo

         clm_pft_out(0) = clm_pft(0)

         clm_pft_out(15) = 0.0

        else

!

!  no information is available to put in data create dataset using grass

!

         do k =1,numpft

           clm_pft_out(k) = 0.0

         enddo

!

!  call the climate subroutine to get the climate information for climate rules

!

         call Climate(lat,temp,prec,T_min,T_max,P_ann,P_min,P_win,T22_wet,GDD)

! 

!  call the grass climate rules to get type

!

         pft = grass_clim_rule (t_min, t_max, GDD, P_ann, P_win, T22_wet)

!

!  for a return of -1 it is a 50% split beteen C3 and C4

!

         if (pft.lt.0)then

          clm_pft_out(13) = 0.5 * pct_pft_in(j,i,15)

          clm_pft_out(14) = 0.5 * pct_pft_in(j,i,15)

         else

          clm_pft_out (pft) = pct_pft_in(j,i,15)

         endif

         clm_pft_out(0) = pct_pft_in(j,i,0)

         clm_pft_out(15) = 0.0

        endif

       endif

!
!  do summations for testing of output
!

       flag=0

       do l = 0,numpft  ! can go with extra sum testing material below

         if(clm_pft_out(l).gt.100.0)flag=1

       enddo

!

       do l = 0,numpft

         pct_pft_out(j,i,l) = clm_pft_out(l)
       enddo

      else
  ! else on ag > 0% ag section
!

!  if there is no agriculture to begin with keep the background vegetation

!

       do l = 0,numpft

         pct_pft_out(j,i,l) = pct_pft_in(j,i,l) 

       enddo

      endif   ! end in ag > 0% ag section

!

    enddo  ! end longitude loop

  enddo   ! end latitude loop

!

!  write out NCAR data

!

  do j=nlat,1,-1

    do i=1,nlon

!
!  make sure the data is precise to the 6th decimal place
!
      sumtest_pft = 100.0_r8 - pct_pft_out(i,j,0) - pct_pft_out(i,j,15)
      sum_pft = 0.0_r8
      do k = 1, 14
        sum_pft = sum_pft + pct_pft_out(i,j,k)
      enddo
!
      do k = 1, 14
        if(pct_pft_out(i,j,k) .gt. 0.000000001)then
         pct_pft_out(i,j,k) = pct_pft_out(i,j,k) * sumtest_pft/sum_pft
        endif
      enddo
!

!  read landmask and pft info

!

      if (landmask(i,j) == 1.) landmask(i,j) = 100.

!

      write (14,*) landmask(i,j),(pct_pft_out(i,j,m),m=0,numpft)

!

    enddo

  enddo

!

stop

end

!

!=====================================================================

!

Subroutine RF_aggregate(xin, yin, rf_pot_in, pot_veg_core, pot_veg_rad1, pot_veg_rad2, pot_flag)

! 

!

!  Subroutine to aggregate percent coverages for R&F potential vegetation

!  does the core grid cell, the 1 st surrounding 8 cells, and the 2 

!  ring of 16 cells.

!

implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: numpot = 15    !number of R&F potential veg classes

  integer :: xin         ! input x array dimension

  integer :: yin         ! input y array dimension

!

  integer :: rf_pot_in(4320,2160)        ! input data

  real(r8) pot_veg_core(numpot)     ! percent coverage by veg type in core cell

  real(r8) pot_veg_rad1(numpot)     ! percent coverage by veg type in 1st ring 

  real(r8) pot_veg_rad2(numpot)     ! percent coverage by veg type in 2nd ring

!

  integer :: pv_core(numpot)     ! summation counter

  integer :: pv_rad1(numpot)     ! summation counter

  integer :: pv_rad2(numpot)     ! summation counter

  integer :: core_count          ! land grid cell counter

  integer :: rad1_count          ! land grid cell counter

  integer :: rad2_count          ! land grid cell counter

  integer :: pot_flag ! flag to indicate completeness of surrounding data

!

  integer :: begin_x(5)          ! start grid indeces for longitude values

  integer :: begin_y(5)          ! start grid indeces for latitude values

  integer :: i

  integer :: j

  integer :: xind

  integer :: yind

!

! get the longitude (x) indeces (all) no ag less than 2 grid cells from dataline 

! so ignore the case of cross dateline interactions

!

  begin_x(1) = (xin-3) * 6 + 1

  begin_x(2) = begin_x(1) + 6

  begin_x(3) = begin_x(2) + 6

  begin_x(4) = begin_x(3) + 6

  begin_x(5) = begin_x(4) + 6

!

! get the beginning latitude (y) index (no ag at the poles; ignore cross pole interactions)

!

  begin_y(1) = (yin-3) * 6 + 1

  begin_y(2) = begin_y(1) + 6

  begin_y(3) = begin_y(2) + 6

  begin_y(4) = begin_y(3) + 6

  begin_y(5) = begin_y(4) + 6

!

!  initialize counters

!

  do i = 1,numpot

    pv_core(i) = 0

    pv_rad1(i) = 0

    pv_rad2(i) = 0

  enddo

  core_count = 0

  rad1_count = 0

  rad2_count = 0

!

!  process each of the 25 grid cells in the area 

!

  do i = 1,5

    do j = 1,5

      do xind = begin_x(i), (begin_x(i)+5)

        do yind = begin_y(j), (begin_y(j)+5)

!

!  if the grid cell is NOT water and NOT barren/ice/rock then process

!

          if (rf_pot_in(xind,yind).gt.0.and.rf_pot_in(xind,yind).lt.15)then

!

!  determine what needs to be summed core, rad1 or rad2

!

           if(i.eq.1.or.i.eq.5.or.j.eq.1.or.j.eq.5)then ! outer ring (2)

!

            pv_rad2(rf_pot_in(xind,yind)) = pv_rad2(rf_pot_in(xind,yind)) + 1

            rad2_count = rad2_count + 1

!

           elseif(i.eq.3.and.j.eq.3)then                ! inner cell (core)

!

            pv_core(rf_pot_in(xind,yind)) = pv_core(rf_pot_in(xind,yind)) + 1

            core_count = core_count + 1

!

           else                                         ! remainder = ring 1

!

            pv_rad1(rf_pot_in(xind,yind)) = pv_rad1(rf_pot_in(xind,yind)) + 1

            rad1_count = rad1_count + 1

!

           endif

          endif

        enddo

      enddo

    enddo

  enddo

!

! process data to get relative percentages

!

  do i= 1, (numpot-1)

    if(core_count.eq.0)then

     pot_veg_core(i) = 0.0

    else

     pot_veg_core(i) = real(pv_core(i)) / real(core_count) * 100.0

    endif

!

    if(rad1_count.eq.0)then

     pot_veg_rad1(i) = 0.0

    else

     pot_veg_rad1(i) = real(pv_rad1(i)) / real(rad1_count) * 100.0

    endif

!

    if(rad2_count.eq.0)then

     pot_veg_rad2(i) = 0.0

    else

     pot_veg_rad2(i) = real(pv_rad2(i)) / real(rad2_count) * 100.0

    endif

  enddo

!

!  set barren/rock/ice to 0.0

!

  pot_veg_core(15) = 0.0

  pot_veg_rad1(15) = 0.0

  pot_veg_rad2(15) = 0.0

!

!  set flag to indicate any missing data (i.e. no cells in rings)

!

  pot_flag = 0

  if(core_count.gt.0)pot_flag = 1                        ! core has data

  if(rad1_count.gt.0)pot_flag = 2                        ! rad1 has data

  if(rad2_count.gt.0)pot_flag = 3                        ! rad2 has data

  if(core_count.gt.0 .and. rad1_count.gt.0)pot_flag = 4  ! core and rad1

  if(core_count.gt.0 .and. rad2_count.gt.0)pot_flag = 5  ! core and rad2

  if(rad1_count.gt.0 .and. rad2_count.gt.0)pot_flag = 6  ! rad1 and rad2

  if(core_count.gt.0 .and. rad1_count.gt.0 .and. rad2_count.gt.0)pot_flag = 7 ! all

!

return

end

!

!=====================================================================

!

Subroutine clm_aggregate(xin,yin,land_mask,clm_pft,veg_core,veg_rad1,veg_rad2,clm_flag)

! 

!

!  Subroutine to aggregate clm pft proportions at the .5 degree level

!  does the core grid cell, the 1st surrounding 8 cells, and the 2nd

!  ring of 16 cells.

!

implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: numpft = 16    !number of clm veg classes

  integer :: xin         ! input x array dimension

  integer :: yin         ! input y array dimension

!

  real(r8) land_mask(720,360)              ! landmask

  real(r8) clm_pft(720,360,0:numpft)       ! input data

  real(r8) veg_core(0:numpft)     ! percent coverage by veg type in core cell

  real(r8) veg_rad1(0:numpft)     ! percent coverage by veg type in 1st ring 

  real(r8) veg_rad2(0:numpft)     ! percent coverage by veg type in 2nd ring

!

  integer :: core_count          ! land grid cell counter

  integer :: rad1_count          ! land grid cell counter

  integer :: rad2_count          ! land grid cell counter

!

  integer :: start_x

  integer :: end_x

  integer :: start_y

  integer :: end_y

  integer :: clm_flag ! flag to indicate completeness of surrounding data

  integer :: i

  integer :: j

  integer :: k

  integer :: indx     ! array index value

  integer :: indy     ! array index value

!

  real(r8) veg_test_c      ! test to see in any nat veg

  real(r8) veg_test_rad1   ! test to see in any nat veg

  real(r8) veg_test_rad2   ! test to see in any nat veg

!

!  initialize the summation values

!

  do i = 0,numpft

    veg_core(i) = 0.0

    veg_rad1(i) = 0.0

    veg_rad2(i) = 0.0

  enddo

!

  rad1_count = 0

  rad2_count = 0

!

! get the row indeces (all)

!

  start_x = xin - 2

  end_x   = xin + 2

  start_y = yin - 2

  end_y   = yin + 2

!

!  Go through each cell in the 25 cell grid and sum areas

! 

  do i = start_x,end_x

    do j = start_y,end_y

!

! make sure to wrap around at the date line

! and identify the adjacent grid cell at the poles (over 360 or 180 degrees)

!

      indx = i

      indy = j

      if(indy.lt.1)then

       indy = 1 - indy

       indx = indx + 360

      endif

      if(indy.gt.360)then

       indy = 360 - (indy-361)

       indx = indx + 360

      endif

      if(indx.lt.1)indx = indx + 720

      if(indx.gt.720)indx = indx - 720

!

! check to see if there is water grid cell

!

      if(land_mask(indx,indy).ne.0.0)then

!

!  sum all non water grid cells in area

!

!  first evaluate the outer 2 rows and add to totals for outer ring

!

       if (i.eq.start_x.or.i.eq.end_x)then

        rad2_count = rad2_count + 1

        do k=0,numpft

          veg_rad2(k) = veg_rad2(k) + clm_pft(indx,indy,k)

        enddo

       endif

!

!  evaluate the middle 2 rows and add to totals for outer and middle rings

!

!  outer cross rows

!

       if(i.eq.(start_x + 1).or.i.eq.(end_x - 1))then

        if(j.eq.start_y.or.j.eq.end_y)then

         rad2_count = rad2_count + 1

         do k=0,numpft

           veg_rad2(k) = veg_rad2(k) + clm_pft(indx,indy,k)

         enddo

        endif

!

!  middle cross rows

!

        if(j.eq.(start_y + 1).or.j.eq.(end_y - 1))then

	 rad1_count = rad1_count + 1

         do k=0,numpft

	   veg_rad1(k) = veg_rad1(k) + clm_pft(indx,indy,k)

         enddo

	endif

!

!  center cross row

!

        if(j.eq.yin)then

         rad1_count = rad1_count + 1

         do k=0,numpft

	   veg_rad1(k) = veg_rad1(k) + clm_pft(indx,indy,k)

         enddo

	endif

       endif

!

!  evaluate the middle row and add to totals for outer, middle and center cell

!

       if(i.eq.(xin))then

!

!  outer rows

!

        if(j.eq.start_y.or.j.eq.end_y)then

         rad2_count = rad2_count + 1

         do k=0,numpft

	   veg_rad2(k) = veg_rad2(k) + clm_pft(indx,indy,k)

         enddo

	endif

!

!  middle rows

!

        if(j.eq.(start_y + 1).or.j.eq.(end_y - 1))then

         rad1_count = rad1_count + 1

         do k=0,numpft

           veg_rad1(k) = veg_rad1(k) + clm_pft(indx,indy,k)

         enddo

        endif

!

!  center row

!

        if(j.eq.yin)then

         do k=0,numpft

           veg_core(k) = clm_pft(indx,indy,k)

         enddo

        endif

       endif

!

      endif  ! end no value/water if check

!	   

    enddo

  enddo

!

!  calculate the averages for the rings

!

  do k=0,numpft

    veg_rad1(k) = veg_rad1(k) / real(rad1_count)

    veg_rad2(k) = veg_rad2(k) / real(rad2_count)

  enddo

!

!  set flag to indicate any missing data (i.e. no cells in rings) or cells with all

!  ag and bare (i.e. no other vegetation to work with)

!

  clm_flag = 0                 

! 

!  for core create test for presence of nat veg

!

  veg_test_c = 100.0 - veg_core(0) - veg_core(15)

  veg_test_rad1 = 100.0 - veg_rad1(0) - veg_rad1(15)

  veg_test_rad2 = 100.0 - veg_rad2(0) - veg_rad2(15)

  if(veg_test_c.gt.0.0)clm_flag = 1                                                    ! core has data

  if(rad1_count.gt.0 .and. veg_test_rad1.gt.0.0)clm_flag = 2                           ! rad1 ring has data

  if(rad2_count.gt.0 .and. veg_test_rad2.gt.0.0)clm_flag = 3                           ! rad2 ring has data

  if(veg_test_c.gt.0.0 .and. (rad1_count.gt.0 .and. veg_test_rad1.gt.0.0))clm_flag = 4 ! core and rad1

  if(veg_test_c.gt.0.0 .and. (rad2_count.gt.0 .and. veg_test_rad2.gt.0.0))clm_flag = 5 ! core and rad2

  if((rad1_count.gt.0 .and. veg_test_rad1.gt.0.0) .and.       &

     (rad2_count.gt.0 .and. veg_test_rad2.gt.0.0))clm_flag = 6                         ! rad1 and rad2

  if(veg_test_c.gt.0.0 .and. (rad1_count.gt.0 .and. veg_test_rad1.gt.0.0) .and.     &

     (rad2_count.gt.0 .and. veg_test_rad2.gt.0.0))clm_flag = 7                         ! all

!

return

end

!

!===================================================================

!  

Subroutine pot_to_clm(pot_veg,mon_temp,mon_prec,ylat,clm_veg)

!

!  subroutine that takes an array of R&F potential vegetation percent

!  coverage in a grid cell (sum to 100) and converts it to a CLM PFT

!  array of percent coverage.

!

!  this conversion does not take into account bare ground, it only identifies

!  the vegetation types to translate to.

!

  implicit none

!

! dimensions - basic parameters first

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: numpft = 16    !number of CLM land cover classes

  integer, parameter :: numpot = 15    !number of R&F potential veg classes

!

!  input variables

!

  real(r8) pot_veg (numpot) ! input array of percent presence of each potential type

  real(r8) mon_temp (12)    ! input monthly temperature at the location

  real(r8) mon_prec (12)    ! input monthly precipitation at the location

  real(r8) ylat             ! input latitude to determine hemisphere location

!

!  output variable

!

  real(r8) clm_veg (0:numpft)! output array of percent presence of each clm type

! 

! climate variables

!

  real(r8) T_min           ! minimum monthly temperature 

  real(r8) T_max           ! maximum monthly temperature 

  real(r8) P_ann           ! annual total precipitation 

  real(r8) P_min           ! minimum monthly precipitation 

  real(r8) P_win           ! winter total precipitation 

  real(r8) GDD             ! annual total growing degrees days 

  integer(r8) T22_wet      ! flag to see if month > 22 have more than 25 mm Prec 1=true

!

!  other variables

!

  integer :: pft  ! index value 

  integer :: pft2  ! index value 

  integer :: i

!

! define the functions for the rules

!

  integer :: NET_clim_rule

  integer :: BET_clim_rule

  integer :: BDT_clim_rule

  integer :: Shrub_clim_rule

  integer :: Grass_clim_rule

!

! call the climate subroutine to get the climate information for climate rules

!

  call Climate(ylat,mon_temp,mon_prec,T_min,T_max,P_ann,P_min,P_win,T22_wet,GDD)

!

!  initialize clm_veg array

!

  do i = 0,numpft

    clm_veg(i) = 0.0

  enddo

!

! treat each veg type seperately and use the climate rulas as appropriate

!

!  R&F type 1 Tropical broadleaf evergreen 

!

  if(pot_veg(1).gt.0)then

!    pft = 4 

   pft = BET_clim_rule (t_min)

   clm_veg (pft) = pot_veg(1) + clm_veg(pft)

  endif

!

!  R&F type 2 Tropical broadleaf deciduous

!

  if(pot_veg(2).gt.0)then

!    pft = 6

   pft = BDT_clim_rule (t_min, GDD)

   clm_veg (pft) = pot_veg(2) + clm_veg(pft)

  endif

!

!  R&F type 3 Temperate broadleaf evergreen 

!

  if(pot_veg(3).gt.0)then

!    pft = 5

   pft = BET_clim_rule (t_min)

   clm_veg (pft) = pot_veg(3) + clm_veg(pft)

  endif

!

!  R&F type 4 Temperate needleleaf evergreen 

!

  if(pot_veg(4).gt.0)then

!    pft = 1

   pft = NET_clim_rule (t_min, GDD)

   clm_veg (pft) = pot_veg(4) + clm_veg(pft)

  endif

!

!  R&F type 5 Temperate broadleaf deciduous

!

  if(pot_veg(5).gt.0)then

!    pft = 7

   pft = BDT_clim_rule (t_min, GDD)

   clm_veg (pft) = pot_veg(5) + clm_veg(pft)

  endif

!

!  R&F type 6 Boreal evergreen 

!

  if(pot_veg(6).gt.0)then

!   pft = 2

   pft = NET_clim_rule (t_min, GDD)

   clm_veg (pft) = pot_veg(6) + clm_veg(pft)

  endif

!

!  R&F type 7 Boreal deciduous  

!

  if(pot_veg(7).gt.0)then

   pft = 3

   clm_veg (pft) = pot_veg(7) + clm_veg(pft)

  endif

!

!  R&F type 8 Temperate BDT and NET mixed

!

  if(pot_veg(8).gt.0)then

!    pft = 1

   pft = BDT_clim_rule (t_min, GDD)

!   pft2 = 7

   pft2 = NET_clim_rule (t_min, GDD)

   clm_veg (pft) = pot_veg(8) * 0.5 + clm_veg(pft)

   clm_veg (pft2) = pot_veg(8) * 0.5 + clm_veg(pft2)

  endif

!

!  R&F type 9 Grassland vegetation 

!

  if(pot_veg(9).gt.0)then

   pft = grass_clim_rule (t_min, t_max, GDD, P_ann, P_win, T22_wet)

!

!  for a return of -1 it is a 50% split beteen C3 and C4

!

   if (pft.lt.0)then

    clm_veg(13) = pot_veg(9) * 0.5 + clm_veg(13)

    clm_veg(14) = pot_veg(9) * 0.5 + clm_veg(14)

   else

    clm_veg (pft) = pot_veg(9) + clm_veg(pft)

   endif

  endif

!

!  R&F type 10 Savanna vegetation (consider 25% tree split?)

!

  if(pot_veg(10).gt.0)then

   pft = grass_clim_rule (t_min, t_max, GDD, P_ann, P_win, T22_wet)

!

!  for a return of -1 it is a 50% split beteen C3 and C4

!

   if (pft.lt.0)then

    clm_veg(13) = pot_veg(10) * 0.5 + clm_veg(13)

    clm_veg(14) = pot_veg(10) * 0.5 + clm_veg(14)

   else

    clm_veg (pft) = pot_veg(10) + clm_veg(pft)

   endif

  endif

!

!  R&F type 11 Dense Shrubland  

!

  if(pot_veg(11).gt.0)then

   pft = Shrub_clim_rule (t_min, GDD, P_ann, P_win)

   clm_veg (pft) = pot_veg(11) + clm_veg(pft)

  endif

!

!  R&F type 12 open Shrubland  (assume LAI will take care of density)

!

  if(pot_veg(12).gt.0)then

   pft = Shrub_clim_rule (t_min, GDD, P_ann, P_win)

   clm_veg (pft) = pot_veg(12) + clm_veg(pft)

  endif

!

!  R&F type 13 Tundra  

!  split equally into grass and shrub

!

  if(pot_veg(13).gt.0)then

   pft = Shrub_clim_rule (t_min, GDD, P_ann, P_win)

   pft2 = grass_clim_rule (t_min, t_max, GDD, P_ann, P_win, T22_wet)

   clm_veg (pft) = pot_veg(13) * 0.5 + clm_veg(pft)

   if (pft2.lt.0)then

    clm_veg(13) = pot_veg(13) * 0.25 + clm_veg(13)

    clm_veg(14) = pot_veg(13) * 0.25 + clm_veg(14)

   else

    clm_veg (pft2) = pot_veg(13) * 0.5 + clm_veg(pft2)

   endif

  endif

!

!  R&F type 14 Desert convert to shrub (some grass?)

!

  if(pot_veg(14).gt.0)then

   pft = Shrub_clim_rule (t_min, GDD, P_ann, P_win)

   clm_veg (pft) = pot_veg(14) + clm_veg(pft)

  endif

!

!  type 15 is barren/rock/ice -- no vegetation to convert

!  could convert to Bare, but use clm bare ground instead

!

return

end    

!

!=====================================================================

!

Subroutine Climate(lat,temp,prec,T_min,T_max,P_ann,P_min,P_win,T22_wet,GDD)

!

! subroutine to calculate all the criteria needed to determine PFT by

! climate rules.  Input is monthly temperature and precipitation from

! Willmott and Matsuura. 

!

  implicit none

!

! input variables

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) lat             ! latitude of the location to decide winter or summer months

  real(r8) temp (12)       ! input monthly temperature for the grid cell

  real(r8) prec (12)       ! input monthly precipitation for the grid cell

!

!output variables

!

  real(r8) T_min           ! minimum monthly temperature 

  real(r8) T_max           ! maximum monthly temperature 

  real(r8) P_ann           ! annual total precipitation 

  real(r8) P_min           ! minimum monthly precipitation 

  real(r8) P_win           ! winter total precipitation 

  real(r8) GDD             ! annual total growing degrees days 

  integer :: T22_wet      ! flag to see if month > 22 have more than 25 mm Prec 1=true



  real(r8) month_days (12) ! array to give the number of days in a month

  integer :: T22_count    ! counter to count months over 22 C

  integer :: T22_prec_count ! counter for month over 22 C and 25 mm prec

  integer :: i            ! loop counter

!

  data month_days/31,28,31,30,31,30,31,31,30,31,30,31/

!

!  Determine the T_min and T_max

!

  T_min = minval(temp)

  T_max = maxval(temp)

  P_min = minval(prec)

  P_ann = sum(prec)

! 

! do a loop to calculate the other variables

!

! set T22_wet to 0 or false; set P_win to 0.0; set GDD to 0.0

!

  T22_count = 0

  T22_prec_count = 0

  GDD = 0.0

  P_win = 0.0

!

  do i =1,12

!

!  check the T22_wet conditions

! 

    if(temp(i) .gt. 22) then

     T22_count = T22_count + 1

     if(prec (i) .le. 25) T22_prec_count = T22_prec_count + 1

    endif

! 

!  check for winter precipitation totals

!

    if (lat .gt. 0) then

     if (i .le. 4 .or. i .ge. 11)then

      P_win = P_win + prec(i)

     endif

    else

     if (i .ge. 5 .and. i .le. 10)then

      P_win = P_win + prec(i)

     endif

    endif

!

!  accumulate GDD for the year

!

    if (temp(i) .gt. 5.0) then

     GDD = GDD + month_days(i) * (temp(i) - 5.0)

    endif

!

  enddo

!

! test the T22 condition if a match and > 0 then true otherwise false

!

  if (T22_count .gt. 0 .and. T22_count .eq. T22_prec_count) then

   T22_wet = 1

  else

   T22_wet = 0

  endif

!

return

end

!

!=====================================================================

!

Function NET_clim_rule (t_min, GDD)

!

!  Funtion to distinguish Needleleaf Evergreen Tree types into Temperate 

!  and Boreal types.  These are based on climate rules from 

!  Bonan et al (2002) and Nemani and Running (1996).

!

  implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) t_min     ! minimum monthly temperature

  real(r8) GDD       ! annual growing degree days

  integer :: NET_clim_rule    ! PFT result

!

  if(T_min .gt. -19.0 .and. GDD .gt. 1200.0)then

   NET_clim_rule = 1

  else

   NET_clim_rule = 2

  endif

!

return

end

!

!=====================================================================

!

Function BET_clim_rule (t_min)

!

!  Funtion to distinguish Broadleaf Evergreen Tree types into Tropical 

!  and Temperate types.  These are based on climate rules from 

!  Bonan et al (2002) and Nemani and Running (1996).

!

  implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) t_min     ! minimum monthly temperature

  integer :: BET_clim_rule    ! PFT result

!

  if(T_min .gt. 15.5)then

   BET_clim_rule = 4

  else

   BET_clim_rule = 5

  endif

!

return

end

!

!=====================================================================

!

Function BDT_clim_rule (t_min, GDD)

!

!  Funtion to distinguish Broadleaf Deciduous Tree types into Tropical,

!  Temperate and Boreal types.  These are based on climate rules from 

!  Bonan et al (2002) and Nemani and Running (1996).

!

  implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) t_min     ! minimum monthly temperature

  real(r8) GDD       ! annual growing degree days

  integer :: BDT_clim_rule    ! PFT result

!

  if(t_min .gt. 15.5) then 

   BDT_clim_rule = 6

  elseif (t_min .gt. -15.0 .and. GDD .gt. 1200.0)then

   BDT_clim_rule = 7

  else

   BDT_clim_rule = 8

  endif

!

return

end

!=====================================================================

!

Function Shrub_clim_rule (t_min, GDD, P_ann, P_win)

!

!  Funtion to distinguish R&F shrub types into Evergreen temperate, 

!  Deciduous temperate and Deciduous boreal types based on climate 

!  rules from Bonan et al (2002) and Nemani and Running (1996).

!  implicit none

!

  implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) t_min     ! minimum monthly temperature

  real(r8) GDD       ! annual growing degree days

  real(r8) P_ann     ! annual precipitation

  real(r8) P_win     ! winter precipitation

  integer :: Shrub_clim_rule    ! PFT result

!

!  as described in Bonan et al. 2002

!

!  if(T_min.gt.-19.0 .and. GDD.gt.1200.0 .and. P_ann .gt. 520.0 .and. P_win .gt. (0.666*P_ann)) then 

!   Shrub_clim_rule = 9

!  elseif (T_min.gt.-19.0 .and. GDD.gt.1200.0.and. (P_ann.le.520.0 .or. (P_win/P_ann).le.0.666))then

!   Shrub_clim_rule = 10

!  else

!   Shrub_clim_rule = 11

!  endif

!

!  as actually done for CLM (Sam Levis)

!

  if(T_min.gt.-19.0 .and. GDD.gt.1200.0)then

   if(P_ann .gt. 520.0 .and. P_win .gt. (0.666*P_ann)) then 

    Shrub_clim_rule = 9

   else

    Shrub_clim_rule = 10

   endif

  else

   Shrub_clim_rule = 11

  endif

!

return

end

!=====================================================================

!

Function Grass_clim_rule (t_min, t_max, GDD, P_ann, P_min, T22_wet)

!

!  Funtion to distinguish Savanna and Grassland buime types into C3 arctic,

!  C3 and C4 grass types These are based on climate rules from 

!  Bonan et al (2002) and Nemani and Running (1996).

!

  implicit none

!

  integer, parameter :: r8 = selected_real_kind(12)
  real(r8) t_min      ! minimum monthly temperature

  real(r8) t_max      ! maximum monthly temperature

  real(r8) GDD        ! annual growing degree days

  real(r8) P_ann      ! annual precipitation

  real(r8) P_min      ! winter precipitation

  integer :: T22_wet ! precipitation in excess of 25 mm when temp > 22C (yes = 1, no = 0)

  integer :: Grass_clim_rule    ! PFT result

!

  if(GDD.ge.1000.0) then 

   if (t_min .ge. 22.0 .and. P_min .gt. 25.0)then

!

! C4 

!

    Grass_clim_rule = 14

   elseif(t_max .le. 22.0 .or. T22_wet .eq. 1)then

!

! C3 

!

    Grass_clim_rule = 13

   else

!

! 50% C4 and 50% C3

!

    Grass_clim_rule = -1

   endif

  else

!

! C3 arctic 

!

   Grass_clim_rule = 12

  endif

!

return

end

!

!===================================================================

!  

Subroutine compare_pft(pot_veg, core_veg, clm25_veg,   &

                       mon_temp, mon_prec,ylat, out_veg)

!

!  subroutine that takes an array of R&F potential pft percent array

!  compares it to the existing pft percentage array and produces an

!  output array of potential pft information.

!

  implicit none

!

! input variables

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: numpft = 16    !number of CLM land cover classes

  real(r8) pot_veg(0:16)   ! potential vegetation types

  real(r8) core_veg(0:16)  ! core cell only for under 15% ag

  real(r8) clm25_veg(0:16) ! clm 25 cell veg 

  real(r8) percent_bare    ! percent of bare ground

  real(r8) percent_ag      ! percent agriculture in the grid cell

  real(r8) mon_temp (12)    ! input monthly temperature at the location

  real(r8) mon_prec (12)    ! input monthly precipitation at the location

  real(r8) ylat             ! input latitude to determine hemisphere location

!

! output variables

!

  real(r8) out_veg(0:16)

! 

! climate variables

!

  real(r8) T_min           ! minimum monthly temperature 

  real(r8) T_max           ! maximum monthly temperature 

  real(r8) P_ann           ! annual total precipitation 

  real(r8) P_min           ! minimum monthly precipitation 

  real(r8) P_win           ! winter total precipitation 

  real(r8) GDD             ! annual total growing degrees days 

  integer :: T22_wet      ! flag to see if month > 22 have more than 25 mm Prec 1=true

  integer :: pft          ! index value 

!

!  local variables

!

  real(r8) clm_veg(0:16)   ! clm veg work array

  real(r8) veg             ! fraction of cell vegetated

  real(r8) RF_weight       ! weighting function to represent potential vegetation

  real(r8) CLM_weight      ! weighting function to represent CLM vegetation

  real(r8) sum_tree        ! summation of tree fraction

  real(r8) tree_adj        ! weighting function reduce tree fractions

  real(r8) other_adj       ! weighting function to increase non tree fractions

  real(r8) fill_ratio      ! ag - total vegetated area

  integer :: k

  real(r8) test_veg(0:16)
  real test

!

  integer :: Grass_clim_rule

!

! use only the core cell info below 15% ag

!
  if(((core_veg(15)*100.0)/(100.0-core_veg(0))).lt.15.0 .or. &
     (100.0-core_veg(0)-core_veg(15)).lt.0.001)then

!
   do k=0,numpft

     clm_veg(k)=core_veg(k)

   enddo

  else
   do k=0,numpft

     clm_veg(k)=clm25_veg(k)

   enddo

  endif

  percent_bare = clm_veg(0)
  percent_ag = clm_veg(15)
!

! determine the portion of vegetated land (i.e not bare)

! 

  veg = 100.0 - percent_bare
!  

! determine the weights based on the percent agriculture 

!  if 15 to 30 percent then use the weighted CLM values to fill in the grid

!  if 30 to 80 use RF weighted from 0 to 0.8 and CLM data from 1 to 0.2

!

  RF_weight = (percent_ag/veg*100.0 - 30.0) / 50.0

  if(RF_weight.le.0.0)then

   RF_weight = 0.0

  elseif(RF_weight.gt.0.8)then

   RF_weight = 0.8

  endif

  CLM_weight = 1.0 - RF_weight

!  write(6,*)'ag',percent_ag,veg,percent_bare 
  if((veg-percent_ag).lt.0.01)then
    RF_weight = 1.0
    CLM_weight = 0.0
  endif
!

! combine the R&F potential vegetation and 

!

  out_veg(0) = percent_bare

!

  sum_tree = 0.0

!

  if((veg - percent_ag) .lt. 0.001)then
    fill_ratio = 1.0
  else
    fill_ratio = veg / (veg - percent_ag)

  endif
!  write(6,*)'fillratio ',fill_ratio,RF_weight,CLM_weight
  do k =1,numpft

    out_veg(k) = RF_weight * pot_veg(k) + CLM_weight * clm_veg(k) * fill_ratio

    if(k.le.8) sum_tree = sum_tree + out_veg(k)

!  write(6,*)k,pot_veg(k),clm_veg(k),out_veg(k)
  enddo

  out_veg(15) = 0.0

!

! scale the values and check that trees do not exceed 80%

!

  if(sum_tree .gt. 80.0) then

   tree_adj = 80.0 / sum_tree
!   write(6,*)'sum-tree ', sum_tree,veg
   if((veg-sum_tree).lt.0.01)then
!   write(6,*)'in if'

!

! assign grass if there is 100% tree cover for all of vegetated fraction

!

! call the climate subroutine to get the climate information for climate rules

!

    call Climate(ylat,mon_temp,mon_prec,T_min,T_max,P_ann,P_min,P_win,T22_wet,GDD)

! 

! call the grass climate rules to get type

!

    pft = grass_clim_rule (t_min, t_max, GDD, P_ann, P_win, T22_wet)

!

! for a return of -1 it is a 50% split beteen C3 and C4

!

    if (pft.lt.0)then

     out_veg(13) = (veg - 80.0) * 0.5
     out_veg(14) = (veg - 80.0) * 0.5

    else

     out_veg (pft) = (veg - 80.0)
    endif

!

!  fix tree percentages

!

    do k =1,8

      out_veg(k) = out_veg(k) * tree_adj

    enddo

!

   else

!

!  if there is some other veg/ag present 
!

    other_adj = (20.0 - percent_bare)/(veg - sum_tree)

    do k =1,numpft

      if(k.le.8) then

       out_veg(k) = out_veg(k) * tree_adj

      else

       out_veg(k) = out_veg(k) * other_adj

      endif

    enddo

   endif

  endif

!

return

end

!

!===================================================================

!  

Subroutine bare_adjust(veg_in, percent_bare, veg_out)

!

!  subroutine that takes an array of R&F potential pft percent array

!  compares it to the existing pft percentage array and produces an

!  output array of potential pft information.

!

  implicit none

!

! input variables

!

  integer, parameter :: r8 = selected_real_kind(12)
  integer, parameter :: numpft = 16    !number of CLM land cover classes

  real(r8) veg_in(0:16)

  real(r8) percent_bare    ! percent of bare ground

!

! output variables

!

  real(r8) veg_out(0:16)

!

!  local variables

!

  real(r8) veg             ! fraction of cell vegetated

  integer :: k

!

! determine the portion of vegetated land (i.e not bare)

! 

  veg = 100.0 - percent_bare

!

!  adjust the RF and CLM data sets so they have the same bare ground fraction as the

!  core grid cell analyzed i.e. contract or expand the proportions of vegetation to fit

!  to a cell with the core cell bare ground fraction

!

   do k = 1,numpft

     veg_out(k) = veg_in(k) * veg / (100.0 - veg_in(0))

   enddo

   veg_out(0) = percent_bare

!

return

end