convert_vegtype.f90

CCSM Research Tools: Community Atmosphere Model (CAM)

           if (k==26 .and. j>=113) k = 29

! Split forest tundra (62, 63) into needleleaf evergreen forest tundra (62) 
! and needleleaf deciduous forest tundra (63) based on longitude

           if (k==63) k = 62
           if (k==62 .and. i>=490) k = 63   

! Error check

           if (k>100 .or. k<0) then
              write (6,*) 'ERROR: Olson surface type = ',k,' is undefined for lon,lat = ',i,j
              Stop
           end if

! Save modified OLSON type 

           surftyp_i(i,j) = k

        end do
     end do

! Assign each of the OLSON surface types to an LSM surface type.
! This mapping from OLSON to LSM is based on the BATS dataset code.
! Note: in2lsm(i) = OLSON type i

     in2lsm(1:19) = miss
     in2lsm(20) = 3 
     in2lsm(21) = 3                                                     
     in2lsm(22) = 3  
     in2lsm(23) = 6 
     in2lsm(24) = 8 
     in2lsm(25) = 9                                               
     in2lsm(26) = 9                                               
     in2lsm(27) = 7       
     in2lsm(28) = 10                                               
     in2lsm(29) = 10                                               
     in2lsm(30) = 24                                               
     in2lsm(31) = 26                                               
     in2lsm(32) = 12                                               
     in2lsm(33) = 10                                               
     in2lsm(34) = miss                                           
     in2lsm(35) = miss                                           
     in2lsm(36) = 28                                              
     in2lsm(37) = 25                                              
     in2lsm(38) = 23                                              
     in2lsm(39) = 23                                              
     in2lsm(40) = 17                                               
     in2lsm(41) = 18                                               
     in2lsm(42) = 17                                               
     in2lsm(43) = 12                                               
     in2lsm(44) = 28                                              
     in2lsm(45) = 28                                              
     in2lsm(46) = 20                                              
     in2lsm(47) = 20                                              
     in2lsm(48) = 20   
     in2lsm(49) = 22                                              
     in2lsm(50) = 2                                               
     in2lsm(51) = 22                                              
     in2lsm(52) = 22   
     in2lsm(53) = 19                                               
     in2lsm(54) = 19                                               
     in2lsm(55) = 15    
     in2lsm(56) = 16   
     in2lsm(57) = 15   
     in2lsm(58) = 16    
     in2lsm(59) = 21                                              
     in2lsm(60) = 6                                              
     in2lsm(61) = 4                                               
     in2lsm(62) = 13    
     in2lsm(63) = 14                                              
     in2lsm(64) = 20                                              
     in2lsm(65) = 0   
     in2lsm(66) = 0   
     in2lsm(67) = 0   
     in2lsm(68) = 0   
     in2lsm(69) = 2                                               
     in2lsm(70) = 1                                             
     in2lsm(71) = 22                                              
     in2lsm(72) = 27                                              
     in2lsm(73) = 0   
     in2lsm(74:100) = miss

  endif

! -----------------------------------------------------------------
! LSM input data : 1:1 correspondence between surface types
! -----------------------------------------------------------------

  if (nvegmax == nlsm) then
     do i = 1, nlsm
        in2lsm(i) = i
     end do
  end if

! -----------------------------------------------------------------
! Transform input surface types to LSM surface types
! -----------------------------------------------------------------

  surftyp_o(:,:) = miss 
  do j = 1 , nlat                                                 
     do i = 1, nlon                                                 
        if (surftyp_i(i,j) == 0) then
           surftyp_o(i,j) = 0
        else
           k = surftyp_i(i,j)
           surftyp_o(i,j) = in2lsm(k)
        end if
        if (surftyp_o(i,j)>nlsm .or. surftyp_o(i,j)<0) then
           write (6,*) 'ERROR: LSM surface type = ',surftyp_o(i,j),' is undefined for lon,lat = ',i,j
           stop
        end if
     end do
  end do

! Write output variables

  call wrap_put_var_realx (ncid, lon_id    , lon)
  call wrap_put_var_realx (ncid, lat_id    , lat)
  call wrap_put_var_realx (ncid, longxy_id , longxy)
  call wrap_put_var_realx (ncid, latixy_id , latixy)
  call wrap_put_var_realx (ncid, edgen_id  , edge(1))
  call wrap_put_var_realx (ncid, edgen_id  , edge(1))
  call wrap_put_var_realx (ncid, edgee_id  , edge(2))
  call wrap_put_var_realx (ncid, edges_id  , edge(3))
  call wrap_put_var_realx (ncid, edgew_id  , edge(4))
  call wrap_put_var_int   (ncid, surftyp_id, surftyp_o)

  call wrap_close(ncid)

end program make_surftype

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

subroutine wrap_create (path, cmode, ncid)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  character(len=*) path
  integer cmode, ncid, ret
  ret = nf_create (path, cmode, ncid)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_create

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

subroutine wrap_def_dim (nfid, dimname, len, dimid)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: nfid, len, dimid
  character(len=*) :: dimname
  integer ret
  ret = nf_def_dim (nfid, dimname, len, dimid)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_def_dim

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

subroutine wrap_def_var (nfid, name, xtype, nvdims, vdims, varid)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: nfid, xtype, nvdims, varid
  integer :: vdims(nvdims)
  character(len=*) :: name
  integer ret
  ret = nf_def_var (nfid, name, xtype, nvdims, vdims, varid)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_def_var

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

subroutine wrap_put_att_text (nfid, varid, attname, atttext)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: nfid, varid
  character(len=*) :: attname, atttext
  integer :: ret, siz
  siz = len_trim(atttext)
  ret = nf_put_att_text (nfid, varid, attname, siz, atttext)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_put_att_text

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

subroutine wrap_put_var_realx (nfid, varid, arr)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: nfid, varid
  real(r8) :: arr(*)
  integer :: ret
#ifdef CRAY
  ret = nf_put_var_real (nfid, varid, arr)
#else
  ret = nf_put_var_double (nfid, varid, arr)
#endif
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_put_var_realx

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

subroutine wrap_put_var_int (nfid, varid, arr)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: nfid, varid
  integer :: arr(*)
  integer :: ret
  ret = nf_put_var_int (nfid, varid, arr)
  if (ret.ne.NF_NOERR) call handle_error (ret)
end subroutine wrap_put_var_int
  
!===============================================================================

subroutine wrap_close (ncid)
  implicit none
  include 'netcdf.inc'
  integer, parameter :: r8 = selected_real_kind(12)
  integer :: ncid
  integer :: ret
  ret = nf_close (ncid)
  if (ret.ne.NF_NOERR) then
     write(6,*)'WRAP_CLOSE: nf_close failed for id ',ncid
     call handle_error (ret)
  end if
end subroutine wrap_close

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

subroutine handle_error(ret)
  implicit none
  include 'netcdf.inc'
  integer :: ret
  if (ret .ne. nf_noerr) then
     write(6,*) 'NCDERR: ERROR: ',nf_strerror(ret)
     call abort
  endif
end subroutine handle_error

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