surffilemod.f90

来自「CCSM Research Tools: Community Atmospher」· F90 代码 · 共 842 行 · 第 1/3 页

                call endrun
             else
                longxy(i,j) = cam_longxy(i,j)
             endif
             if (cam_numlon(j) /= numlon(j)) then                 
                write(6,*)'CAM numlon array different from input CLM2 value' 
                write(6,*)'lat index= ',j,' cam numlon= ',cam_numlon(j), &
                     ' clm2 numlon= ',numlon(j)
                call endrun
             else if (cam_landmask(i,j) /= landmask(i,j)) then         
                write(6,*)'CAM land mask different from input CLM2 value' 
                write(6,*)'lat index= ',j,' lon index= ',i,&
                     ' cam landmask= ',cam_landmask(i,j),' clm2 landmask= ',landmask(i,j)
                call endrun
             elseif (cam_landfrac(i,j) /= landfrac(i,j)) then
                write(6,*)'CAM fractional land different from CLM2 value' 
                write(6,*)'lat index= ',j,' lon index= ',i,&
                     ' cam landmask= ',cam_landfrac(i,j),' clm2 landfrac= ',landfrac(i,j)
                call endrun
             endif
          end do
       end do

       call celledge (lsmlat, lsmlon, numlon, longxy, latixy, &
                      lats  , lonw  )

       call cellarea (lsmlat, lsmlon, numlon, lats, lonw, &
                      area   )
  
#endif   

! Error check: valid PFTs and sum of cover must equal 100

       sumvec(:,:) = abs(sum(pctpft,dim=3)-100.)
       do j=1,lsmlat
          do i=1,numlon(j)
             do m = 1, maxpatch_pft
                if (pft(i,j,m)<0 .or. pft(i,j,m)>numpft) then
                   write(6,*)'SURFRD error: invalid PFT for i,j,m=',i,j,m,pft(i,j,m)
                   call endrun
                end if
             end do
             if (sumvec(i,j)>1.e-04 .and. landmask(i,j)==1) then
                write(6,*)'SURFRD error: PFT cover ne 100 for i,j=',i,j
                do m=1,maxpatch_pft
                   write(6,*)'m= ',m,' pft= ',pft(i,j,m)
                end do
                write(6,*)'sumvec= ',sumvec(i,j)
                call endrun
             end if
          end do
       end do

! Error check: percent glacier, lake, wetland, urban sum must be less than 100

       do j=1,lsmlat
          do i=1,numlon(j)
             sumscl = pctlak(i,j)+pctwet(i,j)+pcturb(i,j)+pctgla(i,j)
             if (sumscl > 100.+1.e-04) then
                write(6,*)'SURFRD error: PFT cover>100 for i,j=',i,j
                call endrun
             end if
          end do
       end do

! Check that urban parameterization is not yet implemented

       do j=1,lsmlat
          do i=1,numlon(j)
             if (pcturb(i,j) /= 0.) then
                write (6,*) 'urban parameterization not yet implemented'
                call endrun
             end if
          end do
       end do

    endif                     !end of if-masterproc block

#if ( defined SPMD )
#if (defined OFFLINE)
    call mpi_bcast (lsmedge , size(lsmedge) , mpir8 , 0, mpicom, ier)
    call mpi_bcast (lats    , size(lats)    , mpir8 , 0, mpicom, ier)
    call mpi_bcast (lonw    , size(lonw)    , mpir8 , 0, mpicom, ier)
    call mpi_bcast (area    , size(area)    , mpir8 , 0, mpicom, ier)
#endif
    call mpi_bcast (numlon  , size(numlon)  , mpiint, 0, mpicom, ier)
    call mpi_bcast (latixy  , size(latixy)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (longxy  , size(longxy)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (landmask, size(landmask), mpiint, 0, mpicom, ier)
    call mpi_bcast (landfrac, size(landfrac), mpir8 , 0, mpicom, ier)
    call mpi_bcast (soic2d  , size(soic2d)  , mpiint, 0, mpicom, ier)
    call mpi_bcast (sand3d  , size(sand3d)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (clay3d  , size(clay3d)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (pctwet  , size(pctwet)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (pctlak  , size(pctlak)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (pctgla  , size(pctgla)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (pcturb  , size(pcturb)  , mpir8 , 0, mpicom, ier)
    call mpi_bcast (pft     , size(pft)     , mpiint, 0, mpicom, ier)
    call mpi_bcast (pctpft  , size(pctpft)  , mpir8 , 0, mpicom, ier)
#endif

! Make patch arrays, [veg] and [wt]:
! [veg] sets the PFT for each of the [maxpatch] patches on the 2d model grid.
! [wt]  sets the relative abundance of the PFT on the 2d model grid.
! Fill in PFTs for vegetated portion of grid cell. Fractional areas for
! these points [pctpft] pertain to "vegetated" area not to total grid area.
! So need to adjust them for fraction of grid that is vegetated.
! Next, fill in urban, lake, wetland, and glacier patches.

    veg(:,:,:) = 0
    wt(:,:,:)  = 0.
    do j=1,lsmlat
       do i=1,numlon(j)
          if (landmask(i,j) == 1) then
             sumscl = pcturb(i,j)+pctlak(i,j)+pctwet(i,j)+pctgla(i,j)
             do m = 1, maxpatch_pft
                veg(i,j,m) = pft(i,j,m)
                wt(i,j,m) = pctpft(i,j,m) * (100.-sumscl)/10000.
             end do
             veg(i,j,npatch_urban) = noveg
             wt(i,j,npatch_urban) = pcturb(i,j)/100.
             veg(i,j,npatch_lake) = noveg
             wt(i,j,npatch_lake) = pctlak(i,j)/100.
             veg(i,j,npatch_wet) = noveg
             wt(i,j,npatch_wet) = pctwet(i,j)/100.
             veg(i,j,npatch_gla) = noveg
             wt(i,j,npatch_gla) = pctgla(i,j)/100.
          end if
       end do
    end do

    sumvec(:,:) = abs(sum(wt,dim=3)-1.)
    do j=1,lsmlat
       do i=1,numlon(j)
          if (sumvec(i,j) > 1.e-06 .and. landmask(i,j)==1) then
             write (6,*) 'SURFRD error: WT > 1 occurs at i,j= ',i,j 
             call endrun
          endif
       end do
    end do

    if ( masterproc )then
       write (6,*) 'Successfully read surface boundary data'
       write (6,*)
    end if

    return
  end subroutine surfrd

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

  subroutine surfwrt(fname, pft, pctpft, mlai, msai, mhgtt, mhgtb)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Write surface data file
!
! Method: 
! 
! Author: Mariana Vertenstein
!
! -----------------------------------------------------------------

    use precision
    use clm_varpar           
    use clm_varsur           
    use clm_varctl
    use fileutils, only : get_filename
    implicit none
    include 'netcdf.inc'

! ------------------------ arguments ------------------------------
    character(len=*), intent(in) :: fname                        !filename to create
    integer , intent(in) :: pft(lsmlon,lsmlat,maxpatch_pft)      !vegetation type
    real(r8), intent(in) :: pctpft(lsmlon,lsmlat,maxpatch_pft)   !vegetation type subgrid weights
    real(r8), intent(in) :: mlai (lsmlon,lsmlat,maxpatch_pft,12) !monthly lai
    real(r8), intent(in) :: msai (lsmlon,lsmlat,maxpatch_pft,12) !monthly sai
    real(r8), intent(in) :: mhgtt(lsmlon,lsmlat,maxpatch_pft,12) !monthly hgt at top
    real(r8), intent(in) :: mhgtb(lsmlon,lsmlat,maxpatch_pft,12) !monthly hgt at bottom
! -----------------------------------------------------------------

! ------------------------ local variables ------------------------
    integer i,m                  !indices
    integer ncid                 !netcdf id
    integer omode                !netcdf output mode
    integer ret                  !netcdf return status

    integer dimtim_id            !id for time dimension
    integer dimlon_id            !id for grid longitude 
    integer dimlat_id            !id for grid latitude 
    integer dimlev_id            !id for soil layer dimension
    integer dimpft_id            !id for plft
    integer dimstr_id            !id for character string variables

#if (defined OFFLINE)
    integer edgen_id             !variable id
    integer edgee_id             !variable id  
    integer edges_id             !variable id
    integer edgew_id             !variable id
#endif
    integer longxy_id            !variable id
    integer latixy_id            !variable id
    integer numlon_id            !variable id
    integer landmask_id          !variable id
    integer landfrac_id          !variable id
    integer soic2d_id            !variable id
    integer sand3d_id            !variable id
    integer clay3d_id            !variable id
    integer pctlak_id            !variable id
    integer pctwet_id            !variable id
    integer pctgla_id            !variable id
    integer pcturb_id            !variable id
    integer pft_id               !variable id
    integer pctpft_id            !variable id
    integer mlai_id              !variable id
    integer msai_id              !variable id
    integer mhgtt_id             !variable id 
    integer mhgtb_id             !variable id

    integer dim1_id(1)           !dim id for 1-d variables
    integer dim2_id(2)           !dim id for 2-d variables
    integer dim3_id(3)           !dim id for 3-d variables
    integer dim4_id(4)           !dim id for 3-d variables
    integer beg4d(4),len4d(4)    !netCDF variable edges

    character(len=256) str       !global attribute string 
    character(len=256) name      !name of attribute
    character(len=256) unit      !units of attribute

    integer values(8)
    character(len=18) datetime
    character(len= 8) date
    character(len=10) time
    character(len= 5) zone
! -----------------------------------------------------------------

! Create new netCDF file. File will be in define mode
! Set fill mode to "no fill" to optimize performance

    call wrap_create (trim(fname), nf_clobber, ncid)

    ret = nf_set_fill (ncid, nf_nofill, omode)
    if (ret .ne. nf_noerr) then
       write (6,*) ' netCDF error = ',nf_strerror(ret)
       call endrun
    end if

! Create global attributes. Attributes are used to store information
! about the data set. Global attributes are information about the
! data set as a whole, as opposed to a single variable

    str = 'NCAR-CSM'
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Conventions', trim(str))

    call date_and_time (date, time, zone, values)
    datetime(1:8) =        date(5:6) // '/' // date(7:8) // '/' // date(3:4)
    datetime(9:)  = ' ' // time(1:2) // ':' // time(3:4) // ':' // time(5:6) // ' '
    str = 'created on: ' // datetime 
    call wrap_put_att_text (ncid, NF_GLOBAL, 'History', trim(str))

    call getenv ('LOGNAME', str)
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Logname',trim(str))

    call getenv ('HOST', str)
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Host', trim(str))

    str = 'Community Land Model: CLM2'
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Source', trim(str))

    str = '$Name: cam2_0_brnchT_release3 $' 
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Version', trim(str))

    str = '$Id: surfFileMod.F90,v 1.13.2.4.6.1 2002/05/13 19:25:08 erik Exp $'
    call wrap_put_att_text (ncid, NF_GLOBAL, 'Revision_Id', trim(str))

    if (offline_rdgrid) then
       str = mksrf_offline_fgrid
       call wrap_put_att_text(ncid, NF_GLOBAL, 'Input_grid_dataset', trim(str))
    else
       str = mksrf_offline_fnavyoro