API tools faq
paste
Advertisement
Guest User

ISAM Output code

a guest
Dec 26th, 2012
94
0
Never
Add comment
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
Fortran 9.41 KB | None | 0 0
raw download clone embed print report
  1. module bgp_to_bgc_weekly_initial_module
  2.   use shr_kind_module, only: r8 => shr_kind_r8
  3.  
  4.   implicit none
  5.  
  6.   private
  7.  
  8.   !---------------------------------------------------------------------------------------------------------
  9.   ! Weekly (Accumulation) initial variables
  10.   !---------------------------------------------------------------------------------------------------------
  11.   real(r8), dimension(:,:,:), allocatable :: c_litter_ag_lf_weekly    ! Weekly Above ground leaf litter
  12.   real(r8), dimension(:,:,:), allocatable :: c_litter_ag_wd_weekly    ! Weekly abive ground wood litter
  13.   real(r8), dimension(:,:,:), allocatable :: c_litter_bg_weekly       ! Weekly Below ground litter
  14.   real(r8), dimension(:,:,:), allocatable :: c_litter_bg_fr_weekly    ! Weekly Below ground fine litter
  15.   real(r8), dimension(:,:,:), allocatable :: c_litter_bg_cr_weekly    ! Weekly Below ground coarse litter
  16.   real(r8), dimension(:,:,:), allocatable :: c_litter_ag_lf_n_weekly  ! Weekly Below ground leaf litter N
  17.   real(r8), dimension(:,:,:), allocatable :: c_litter_ag_wd_n_weekly  ! Weekly Below ground wood litter N
  18.   real(r8), dimension(:,:,:), allocatable :: c_litter_bg_fr_n_weekly  ! Weekly Below ground fine litter N
  19.   real(r8), dimension(:,:,:), allocatable :: c_litter_bg_cr_n_weekly  ! Weekly Below ground coarse litter N
  20.   real(r8), dimension(:,:,:), allocatable :: c_npp_weekly            ! Weekly NPP
  21.  
  22.  
  23.  
  24. contains
  25.  
  26. !===========================================================================================================
  27. ! SUBROUTINE bgp_to_bgc_weekly_initial
  28. !===========================================================================================================
  29.   subroutine bgp_to_bgc_weekly_initialize()
  30.  
  31.     use isam_domain, only: myigp_begin, myigp_end, myigp_num
  32.  
  33.     implicit none
  34.  
  35.     integer :: ierr !< Local error value
  36.  
  37.     ! weekly values, for each PFT pool
  38.     allocate(c_litter_ag_lf_weekly  (myigp_begin:myigp_end,numpft,52), stat=ierr)
  39.     allocate(c_litter_ag_wd_weekly  (myigp_begin:myigp_end,numpft,52),  stat=ierr)
  40.     allocate(c_litter_bg_weekly     (myigp_begin:myigp_end,numpft,52), stat=ierr)
  41.     allocate(c_litter_bg_fr_weekly  (myigp_begin:myigp_end,numpft,52), stat=ierr)
  42.     allocate(c_litter_bg_cr_weekly  (myigp_begin:myigp_end,numpft,52), stat=ierr)
  43.     allocate(c_litter_ag_lf_n_weekly(myigp_begin:myigp_end,numpft,52), stat=ierr)
  44.     allocate(c_litter_ag_wd_n_weekly(myigp_begin:myigp_end,numpft,52), stat=ierr)
  45.     allocate(c_litter_bg_fr_n_weekly(myigp_begin:myigp_end,numpft,52), stat=ierr)
  46.     allocate(c_litter_bg_cr_n_weekly(myigp_begin:myigp_end,numpft,52), stat=ierr)
  47.     allocate(c_npp_weekly           (myigp_begin:myigp_end,numpft,52), stat=ierr)
  48.  
  49.   end subroutine bgp_to_bgc_weekly_initialize
  50.  
  51.   subroutine bgp_to_bgc_weekly_write()
  52.  
  53.     call write_weekly_pft_file('Writing leaf litter file', &
  54.          bgp_to_bgc_initial_litter_ag_lf_nc_file, &
  55.          'c_litter_ag_lf_weekly', 'Weekly above ground leaf litter', 'gC/m2/wk', &
  56.          c_litter_ag_lf_weekly)
  57.  
  58.     call write_weekly_pft_file('Writing BGP_to_BGC wood litter file', &
  59.          bgp_to_bgc_initial_litter_ag_wd_nc_file, &
  60.          'c_litter_ag_wd_weekly', 'Weekly above ground wood litter', 'gC/m2/wk', &
  61.          c_litter_ag_wd_weekly)
  62.  
  63.     call write_weekly_pft_file('Writing BGP_to_BGC total BG litter file', &
  64.          bgp_to_bgc_initial_litter_bg_nc_file, &
  65.          'c_litter_bg_weekly', 'Weekly below ground litter', 'gC/m2/wk', &
  66.          c_litter_bg_weekly)
  67.  
  68.     call write_weekly_pft_file('Writing BGP_to_BGC fine root litter file', &
  69.          bgp_to_bgc_initial_litter_bg_fr_nc_file, &
  70.          'c_litter_bg_fr_weekly', 'Weekly below ground fine root litter', 'gC/m2/wk', &
  71.          c_litter_bg_fr_weekly)
  72.  
  73.     call write_weekly_pft_file('Writing BGP_to_BGC coarse root litter file', &
  74.          bgp_to_bgc_initial_litter_bg_cr_nc_file, &
  75.          'c_litter_bg_cr_weekly', 'Weekly below ground coarse root litter', 'gC/m2/wk', &
  76.          c_litter_bg_cr_weekly)
  77.  
  78.     call write_weekly_pft_file('Writing BGP_to_BGC leaf N litter file', &
  79.          bgp_to_bgc_initial_litter_ag_lf_n_nc_file, &
  80.          'c_litter_ag_lf_n_weekly', 'Weekly above ground leaf litter N', 'gN/m2/wk', &
  81.          c_litter_ag_lf_n_weekly)
  82.  
  83.     call write_weekly_pft_file('Writing BGP_to_BGC wood N litter file', &
  84.          bgp_to_bgc_initial_litter_ag_wd_n_nc_file, &
  85.          'c_litter_ag_wd_n_weekly', 'Weekly above ground wood litter N', 'gN/m2/wk', &
  86.          c_litter_ag_wd_n_weekly)
  87.  
  88.     call write_weekly_pft_file('Writing BGP_to_BGC fine root N litter file', &
  89.          bgp_to_bgc_initial_litter_bg_fr_n_nc_file, &
  90.          'c_litter_bg_fr_n_weekly', 'Weekly below ground fine litter N', 'gN/m2/wk', &
  91.          c_litter_bg_fr_n_weekly)
  92.  
  93.     call write_weekly_pft_file('Writing BGP_to_BGC coarse root N litter file', &
  94.          bgp_to_bgc_initial_litter_bg_cr_n_nc_file, &
  95.          'c_litter_bg_cr_n_weekly', 'Weekly below  ground coarse root litter N', 'gN/m2/wk', &
  96.          c_litter_bg_cr_n_weekly)
  97.  
  98.     call write_weekly_pft_file('Writing BGP_to_BGC NPP file', &
  99.          bgp_to_bgc_initial_npp_nc_file, &
  100.          'c_npp_weekly', 'Weekly npp', 'gC/m2/wk', &
  101.          c_npp_weekly)
  102.  
  103.     return
  104.  
  105.   end subroutine bgp_to_bgc_weekly_write
  106.  
  107.    subroutine write_weekly_pft_file(message, file_name, var_name, var_description, var_units, var_values)
  108.      use netcdf
  109.      use pnetcdf
  110.      use isam_domain, only: numlon, numlat, latitude, longitude
  111.      use isam_comm, only: myid, isam_mpi_comm
  112.      use isam_data_collect
  113.      use mpi, only: MPI_INFO_NULL
  114.  
  115.      implicit none
  116.  
  117.      character(*), intent(in) :: message, file_name, var_name, var_description, var_units
  118.      real(r8), intent(inout) :: var_values(myigp_begin:myigp_end, 1:numpft, 1:52)
  119.  
  120.      ! dimids(:) = lat, lon, numpft, week
  121.      integer :: dimids(4)
  122.      integer :: ierr, i, j
  123.      integer :: nc, varidlat, varidlon, varidv
  124.      integer(kind=MPI_OFFSET_KIND) :: onumlon, onumlat, onumpft, len_desc, len_unit
  125.  
  126.      if (myid .eq. 0) then
  127.         print *, 'WRITE_BGP_TO_BGC: ', message
  128.      end if
  129.  
  130.      call nc_check(nfmpi_create(isam_mpi_comm, trim(file_name), nf_clobber, MPI_INFO_NULL, nc))
  131.  
  132.      onumlon = numlon
  133.      onumlat = numlat
  134.      onumpft = numpft
  135.  
  136.      call nc_check(nfmpi_def_dim(nc, 'lon', onumlon, dimids(1)))
  137.      call nc_check(nfmpi_def_dim(nc, 'lat', onumlat, dimids(2)))
  138.  
  139.      ! Define the longitudinal variable
  140.      call nc_check(nfmpi_def_var(nc, 'lon', NF90_DOUBLE, 1, dimids(1), varidlon))
  141.      call nc_check(nfmpi_put_att_text(nc, varidlon, 'long_name', 9, 'longitude'))
  142.      call nc_check(nfmpi_put_att_text(nc, varidlon, 'units', 12, 'degrees_east'))
  143.  
  144.      ! Define the latitudinal variable
  145.      call nc_check(nfmpi_def_var(nc, 'lat', NF90_DOUBLE, 1, dimids(2), varidlat))
  146.      call nc_check(nfmpi_put_att_text(nc, varidlat, 'long_name', 8, 'latitude'))
  147.      call nc_check(nfmpi_put_att_text(nc, varidlat, 'units', 13, 'degrees_north'))
  148.  
  149.      ! Set 4D variable
  150.      call nc_check(nfmpi_def_dim(nc, 'pft', onumpft, dimids(3)))
  151.      call nc_check(nfmpi_def_dim(nc, 'weeks', 52, dimids(4)))
  152.  
  153.      len_desc = len_trim(var_description)
  154.      len_unit = len_trim(var_units)
  155.  
  156.      call nc_check(nfmpi_def_var(nc, var_name, NF90_DOUBLE, 4, dimids, varidv))
  157.      call nc_check(nfmpi_put_att_text(nc, varidv, 'long_name', len_desc, var_description))
  158.      call nc_check(nfmpi_put_att_text(nc, varidv, 'units', len_unit, var_units))
  159.  
  160.      call nc_check(nfmpi_enddef(nc))
  161.  
  162.      if (myid == 0) print *, 'Finished definition mode'
  163.  
  164.      call nc_check(nfmpi_begin_indep_data(nc))
  165.      if (myid .eq. 0) then
  166.         call nc_check(nfmpi_put_var_double(nc, varidlon, longitude))
  167.         call nc_check(nfmpi_put_var_double(nc, varidlat, latitude))
  168.      end if
  169.      call nc_check(nfmpi_end_indep_data(nc))
  170.  
  171.      if (myid == 0) print *, 'Wrote lat/lon'
  172.  
  173.      call write_weekly_pft_variable(nc, varidv, var_values)
  174.  
  175.      !var_values(:,:,:) = 0._r8
  176.    end subroutine write_weekly_pft_file
  177.  
  178.    subroutine write_weekly_pft_variable(nfid, varidv, values)
  179.      use pnetcdf
  180.      use mpi, only: MPI_OFFSET_KIND
  181.      use isam_domain, only: myigp_begin, myigp_end, myigp_num, mask
  182.      use isam_comm, only: myid, isam_mpi_comm
  183.  
  184.      integer, intent(in) :: nfid, varidv    ! Parallel-NetCDF file descriptor and variable ID
  185.      real(r8), intent(in) :: values(myigp_begin:myigp_end, 1:numpft, 1:52)
  186.  
  187.      integer :: i, stat
  188.      integer(MPI_OFFSET_KIND) :: start(4), nvals(4)
  189.      integer, allocatable :: reqs(:), stats(:)
  190.  
  191.      allocate(reqs(myigp_begin:myigp_end), stats(myigp_begin:myigp_end))
  192.  
  193.      nvals(1) = 1
  194.      nvals(2) = 1
  195.      nvals(3) = numpft
  196.      nvals(4) = 52
  197.  
  198.      start(3) = 1
  199.      start(4) = 1
  200.  
  201.      do i = myigp_begin, myigp_end
  202.         start(1) = mask(i, 2)
  203.         start(2) = mask(i, 3)
  204.         call nc_check(nfmpi_iput_vara_double(nfid, varidv, start, nvals, values(i,:,:), reqs(i)))
  205.         base = base + stride
  206.  
  207.         if (myid == 0) print *, 'Put data', i, start(1), start(2), myigp_num
  208.      end do
  209.  
  210.      if (myid == 0) print *, 'Put all data', myigp_num, size(reqs), (myigp_end-myigp_begin+1)
  211.  
  212.      call nc_check(nfmpi_wait_all(nfid, myigp_num, reqs, stats))
  213.  
  214.      if (myid == 0) print *, 'Requests completed', myid
  215.  
  216.      call nc_check(nfmpi_close(nfid))
  217.      if (myid == 0) print *, 'Closed file'
  218.  
  219.      deallocate(reqs, stats)
  220.    end subroutine write_weekly_pft_variable
  221.  
  222. end module bgp_to_bgc_weekly_initial_module
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement
Public Pastes
Advertisement
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy.  OK, I Understand
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!