inicfilemod.f90

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

    ! Write out snlsno
    do k = begpatch,endpatch
       ibuf1dp(k) = clm(k)%snl     
    end do
    call patch_to_land (ibuf1dp, ibuf1dl)
    if (masterproc) call wrap_put_var_int (ncid, snlsno_id, ibuf1dl)

#if (defined RTM)
    ! Write out volr
    if (masterproc) call wrap_put_var_realx (ncid, volr_id, volr)
#endif

    deallocate (ibuf1dl)
    deallocate (rbuf1dl)
    deallocate (ibuf1dp)
    deallocate (rbuf1dp)

! archive initial conditions dataset (Mass Store currently)

    if (masterproc) then
       call wrap_close (ncid)
       if (mss_irt > 0) then 
          rem_dir = trim(archive_dir) // '/init/'
          rem_fn = set_filename(rem_dir, loc_fn)
          call putfil (loc_fn, rem_fn, mss_wpass, mss_irt, .true.)
       endif
    endif

    return
  end subroutine inicwrt

!=======================================================================
! BEGIN GENERIC PROCEDURE DEFINITIONS
!=======================================================================

  logical function do_inicwrite()

    use time_manager, only : get_curr_date, get_prev_date
    use clm_varctl, only : hist_crtinic

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Determine if initial dataset is to be written at this time step
!
! Method: 
!
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

! ------------------------ local variables ------------------------
    integer :: yr         !nstep year (0 -> ...)
    integer :: yrm1       !nstep-1 year (0 -> ...)
    integer :: daym1      !nstep-1 day (1 -> 31)
    integer :: day        !nstep day (1 -> 31)
    integer :: mon        !nstep month (1 -> 12)
    integer :: monm1      !nstep-1 month (1 -> 12)
    integer :: mcsec      !nstep time of day [seconds] 
    integer :: mcsecm1    !nstep-1 time of day [seconds]
! -----------------------------------------------------------------

    ! Set calendar for current time step and previous time step

    call get_curr_date (yr, mon, day, mcsec) 
    call get_prev_date (yrm1, monm1, daym1, mcsecm1)

    ! Determine if time to write out initial dataset

    do_inicwrite = .false.
    if (hist_crtinic /= 'NONE') then
       if (hist_crtinic == 'MONTHLY') then
          if (mon /= monm1 .and. monm1 /= -1) do_inicwrite = .true.
       else if (hist_crtinic == 'YEARLY') then
          if (monm1 == 12 .and. mon == 1)  do_inicwrite = .true.
       endif
    endif

  end function do_inicwrite

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

  character(len=256) function set_init_filename ()

!----------------------------------------------------------------------- 
! 
! Purpose: 
! Determine initial dataset filenames
! 
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use clm_varctl  , only : caseid
    use time_manager, only : get_curr_date

! ------------------------ local variables ------------------------
    character(len=256) :: cdate       !date char string
    integer :: day                    !day (1 -> 31)
    integer :: mon                    !month (1 -> 12)
    integer :: yr                     !year (0 -> ...)
    integer :: sec                    !seconds into current day
! -----------------------------------------------------------------

    call get_curr_date (yr, mon, day, sec) 
    write(cdate,'(i4.4,"-",i2.2,"-",i2.2,"-",i5.5)') yr,mon,day,sec
    set_init_filename = "./"//trim(caseid)//".clm2.i."//trim(cdate)//".nc"

  end function set_init_filename

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

!----------------------------------------------------------------------- 
! 
! Purpose: 
! [numland] x [maxpatch] array from 1d subgrid patches
!
! Method: 
! Map a subgrid input vector [fldin] of length [numpatch] to a 2-d
! [numland] x [maxpatch] output array [fldout]. Not all land points have
! [maxpatch] subgrid patches. Many have less. [numpatch] is some number <=
! [numland]*[maxpatch], i.e., is valid subgrid patches only. This routine
! converts a field from its [numpatch] representation to a [numland] x 
! [maxpatch] representation, setting values for non-valid subgrid patches 
! to that of the first valid subgrid patch using mapping from clm_map
! o numland  = number of land grid cells
! o maxpatch = maximum number of subgrid patches per grid cell
! o numpatch = actual number of subgrid patches (<= numland*maxpatch)
! 
!-----------------------------------------------------------------------

  subroutine patch_to_land_1d_int (fldin, fldout)
! ------------------------ arguments ---------------------------------
    integer, intent(in)  :: fldin(begpatch:endpatch)          
    integer, intent(out) :: fldout(numland,maxpatch) 
! --------------------------------------------------------------------

! ------------------------ local variables ----------------------
    integer l,m,k                   !indices
#if (defined SPMD)
    integer :: ier                   !MPI error status
    integer :: ibuf1d(numpatch)      !MPI temporary buffer 
    integer :: numrecvv(0:npes-1)    !vector of items to be received  
    integer :: displsv(0:npes-1)     !displacement vector
    integer :: numsend               !number of items to be sent
! ---------------------------------------------------------------
    call compute_mpigs_patch(1, numsend, numrecvv, displsv)
    call mpi_gatherv (fldin(begpatch), numsend , mpiint,  &
         ibuf1d, numrecvv, displsv, mpiint, 0, mpicom, ier)
    if (masterproc) then
       do m = 1, maxpatch           !subgrid patches for each land point
          do l = 1, numland         !land point index for [lsmlon] x [lsmlat] grid
             k = landvec%patch(l,m) !subgrid patch index: [1] to [numpatch]
             fldout(l,m) = ibuf1d(k)
          end do
       end do
    endif
#else 
    do m = 1, maxpatch              !subgrid patches for each land point
       do l = 1, numland            !land point index for [lsmlon] x [lsmlat] grid
          k = landvec%patch(l,m)    !subgrid patch index: [1] to [numpatch]
          fldout(l,m) = fldin(k)
       end do
    end do
#endif
    return
  end subroutine patch_to_land_1d_int

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

  subroutine patch_to_land_1d_real (fldin, fldout)
! ------------------------ arguments ---------------------------------
    real(r8), intent(in)  :: fldin(begpatch:endpatch)          
    real(r8), intent(out) :: fldout(numland,maxpatch) 
! --------------------------------------------------------------------
! ------------------------ local variables ----------------------
    integer l,m,k                   !indices
#if (defined SPMD)
    integer  :: ier                 !MPI error status
    real(r8) :: buf1d(numpatch)     !MPI temporary buffer 
    integer  :: numrecvv(0:npes-1)  !vector of items to be received  
    integer  :: displsv(0:npes-1)   !displacement vector
    integer  :: numsend             !number of items to be sent
! ---------------------------------------------------------------
    call compute_mpigs_patch(1, numsend, numrecvv, displsv)
    call mpi_gatherv (fldin(begpatch), numsend , mpir8, &
         buf1d, numrecvv, displsv, mpir8  , 0, mpicom, ier)
    if (masterproc) then
       do m = 1, maxpatch           !subgrid patches for each land point
          do l = 1, numland         !land point index for [lsmlon] x [lsmlat] grid
             k = landvec%patch(l,m) !subgrid patch index: [1] to [numpatch]
             fldout(l,m) = buf1d(k)
          end do
       end do
    endif
#else 
    do m = 1, maxpatch               !subgrid patches for each land point
       do l = 1, numland             !land point index for [lsmlon] x [lsmlat] grid
          k = landvec%patch(l,m)     !subgrid patch index: [1] to [numpatch]
          fldout(l,m) = fldin(k)
       end do
    end do
#endif
    return
  end subroutine patch_to_land_1d_real

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

  subroutine patch_to_land_2d_real (fldin, fldout, nlev)
! ------------------------ arguments ---------------------------------
    integer , intent(in)  :: nlev
    real(r8), intent(in)  :: fldin(nlev,begpatch:endpatch)
    real(r8), intent(out) :: fldout(numland,maxpatch,nlev) 
! --------------------------------------------------------------------
! ------------------------ local variables ----------------------
    integer l,m,k,n                    !indices
#if (defined SPMD)                    
    integer  :: ier                   !MPI error status
    real(r8) :: buf2d(nlev,numpatch)  !MPI temporary buffer
    integer  :: numrecvv(0:npes-1)    !vector of items to be received  
    integer  :: displsv(0:npes-1)     !displacement vector
    integer  :: numsend               !number of items to be sent
! ---------------------------------------------------------------
    call compute_mpigs_patch(nlev, numsend, numrecvv, displsv)
    call mpi_gatherv (fldin(1,begpatch), numsend , mpir8, &
         buf2d, numrecvv, displsv, mpir8, 0, mpicom, ier)
    if (masterproc) then
       do m = 1, maxpatch           !subgrid patches for each land point
          do l = 1, numland         !land point index for [lon] x [lat] grid
             k = landvec%patch(l,m) !subgrid patch index: [1] to [numpatch]
             do n = 1,nlev          !level index 
                fldout(l,m,n) = buf2d(n,k)
             end do
          end do
       end do
    endif
#else
    do m = 1,maxpatch               !subgrid patches for each land point
       do l = 1,numland             !land point index for [lon] x [lat] grid
          k = landvec%patch(l,m)    !subgrid patch index: [1] to [numpatch]
          do n = 1,nlev             !level index 
             fldout(l,m,n) = fldin(n,k)
          end do
       end do
    end do
#endif
    return
  end subroutine patch_to_land_2d_real

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

  subroutine land_to_patch_1d_int (fldin, fldout)
! ------------------------ arguments ---------------------------------
    integer, intent(in)  :: fldin(numland,maxpatch)
    integer, intent(out) :: fldout(begpatch:endpatch)
! --------------------------------------------------------------------
! ------------------------ local variables ----------------------
    integer l,m,k                   !indices
#if (defined SPMD)
    integer :: ier                  !MPI error status
    integer :: ibuf1d(numpatch)     !MPI temporary buffer
    integer :: numsendv(0:npes-1)   !vector of items to be sent
    integer :: displsv(0:npes-1)    !displacement vector
    integer :: numrecv              !number of items to be received
! ---------------------------------------------------------------
    if (masterproc) then
       do m = 1, maxpatch              !subgrid patches for each land point
          do l = 1, numland            !land point index 
             if (landvec%wtxy(l,m) > 0.) then
                k = landvec%patch(l,m) !subgrid patch index
                ibuf1d(k) = fldin(l,m)
             end if
          end do
       end do
    endif
    call compute_mpigs_patch(1, numrecv, numsendv, displsv)
    call mpi_scatterv (ibuf1d, numsendv, displsv, mpiint, &
         fldout(begpatch), numrecv , mpiint, 0, mpicom, ier)
#else
    do m = 1, maxpatch                !subgrid patches for each land point
       do l = 1, numland              !land point index 
          if (landvec%wtxy(l,m) > 0.) then
             k = landvec%patch(l,m)   !subgrid patch index
             fldout(k) = fldin(l,m)
          endif
       end do
    end do
#endif
    return
  end subroutine land_to_patch_1d_int

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

  subroutine land_to_patch_1d_real (fldin, fldout)
! ------------------------ arguments ---------------------------------
    real(r8), intent(in)  :: fldin(numland,maxpatch)
    real(r8), intent(out) :: fldout(begpatch:endpatch)
! --------------------------------------------------------------------
! ------------------------ local variables ----------------------
    integer l,m,k  !indices
#if (defined SPMD)
    integer  :: ier                  !MPI error status
    real(r8) :: buf1d(numpatch)      !MPI temporary buffer
    integer  :: numsendv(0:npes-1)   !vector of items to be sent
    integer  :: displsv(0:npes-1)    !displacement vector
    integer  :: numrecv              !number of items to be received
! ---------------------------------------------------------------
    if (masterproc) then
       do m = 1, maxpatch             !subgrid patches for each land point
          do l = 1, numland           !land point index 
             if (landvec%wtxy(l,m) > 0.) then
                k = landvec%patch(l,m) !subgrid patch index
                buf1d(k) = fldin(l,m)
             end if
          end do
       end do
    endif
    call compute_mpigs_patch(1, numrecv, numsendv, displsv)
    call mpi_scatterv (buf1d, numsendv, displsv, mpir8, &
         fldout(begpatch), numrecv , mpir8  , 0, mpicom, ier)
#else
    do m = 1, maxpatch              !subgrid patches for each land point
       do l = 1, numland            !land point index 
          if (landvec%wtxy(l,m) > 0.) then
             k = landvec%patch(l,m) !subgrid patch index
             fldout(k) = fldin(l,m)
          endif
       end do
    end do
#endif
    return
  end subroutine land_to_patch_1d_real

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

  subroutine land_to_patch_2d_real (fldin, fldout, nlev)
! ------------------------ arguments ---------------------------------
    integer , intent(in)  :: nlev
    real(r8), intent(in)  :: fldin (numland,maxpatch,nlev) 
    real(r8), intent(out) :: fldout(nlev,begpatch:endpatch)
! --------------------------------------------------------------------
! ------------------------ local variables ----------------------
    integer l,m,k,n                   !indices
#if (defined SPMD)                   
    integer  :: ier                   !MPI error status
    real(r8) :: buf2d(nlev,numpatch)  !MPI temporary buffer
    integer  :: numsendv(0:npes-1)    !vector of items to be sent
    integer  :: displsv(0:npes-1)     !displacement vector
    integer  :: numrecv               !number of items to be received
! ---------------------------------------------------------------
    if (masterproc) then
       do m = 1, maxpatch             !subgrid patches for each land point
          do l = 1, numland           !land point index 
             if (landvec%wtxy(l,m) > 0.) then
                k = landvec%patch(l,m) !subgrid patch index
                do n = 1,nlev
                   buf2d(n,k) = fldin(l,m,n)
                end do
             end if
          end do
       end do
    endif
    call compute_mpigs_patch(nlev, numrecv, numsendv, displsv)
    call mpi_scatterv (buf2d, numsendv, displsv, mpir8, &
         fldout(1,begpatch), numrecv , mpir8  , 0, mpicom, ier)
#else
    do m = 1, maxpatch               !subgrid patches for each land point
       do l = 1, numland             !land point index 
          k = landvec%patch(l,m)  !subgrid patch index
          if (landvec%wtxy(l,m) > 0.) then
             do n = 1,nlev
                fldout(n,k) = fldin(l,m,n)
             end do
          endif
       end do
    end do
#endif
    return
  end subroutine land_to_patch_2d_real

!=======================================================================
! END GENERIC PROCEDURE DEFINITIONS
!=======================================================================

end module inicFileMod