histfilemod.f90

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

    endif

! time comment for history interval

    if (masterproc) then
       beg2d(1) = 1        ; len2d(1) = len_trim(timcom(nf))
       beg2d(2) = ntim(nf) ; len2d(2) = 1
       call wrap_put_vara_text (ncid(nf), timcom_id(nf), beg2d, len2d, timcom(nf))
    endif

! active single-level fields (either grid averages or 1-d vectors)

#if (defined SPMD)
    if (slfld%num(nf) > 0) then
       allocate (buf1d(begpatch:endpatch))
       allocate (gather1d(numpatch))
       call compute_mpigs_patch(1, numsend, numrecvv, displsv)
       do n = 1, slfld%num(nf)
          do k = begpatch, endpatch
             buf1d(k) = slfld%value(k,n,nf)
          end do
          call mpi_gatherv (buf1d(begpatch), numsend , mpir8, &
               gather1d, numrecvv, displsv, mpir8, 0, mpicom, ier)
          if (masterproc) then
             do k = 1, numpatch
                slfld%value(k,n,nf) = gather1d(k) 
             end do
          endif
       end do
       deallocate (buf1d)
       deallocate (gather1d)
    endif
#endif
    if (masterproc) then
       if (hist_dov2xy(nf)) then
          beg3d(1) = 1        ; len3d(1) = lsmlon
          beg3d(2) = 1        ; len3d(2) = lsmlat
          beg3d(3) = ntim(nf) ; len3d(3) = 1
          do i = 1, slfld%num(nf)
             call v2xy (slfld%value(1,i,nf), spval, slfxy)
             call wrap_put_vara_realx (ncid(nf), slfld_id(i,nf), beg3d, len3d, slfxy)
          end do
       else
          beg2d(1) = 1        ; len2d(1) = numpatch
          beg2d(2) = ntim(nf) ; len2d(2) = 1
          do i = 1, slfld%num(nf)
             call wrap_put_vara_realx (ncid(nf), slfld_id(i,nf), beg2d, len2d, slfld%value(1,i,nf))
          end do
       endif
    endif

! active multi-level soil fields (either grid averages or 1-d vectors)

#if (defined SPMD)
    if (mlsoifld%num(nf) > 0) then
       allocate (buf2d(nlevsoi,begpatch:endpatch))
       allocate (gather2d(nlevsoi,numpatch))
       call compute_mpigs_patch(nlevsoi, numsend, numrecvv, displsv)
       do n = 1, mlsoifld%num(nf)
          do l = 1, nlevsoi
             do k = begpatch, endpatch
                buf2d(l,k) = mlsoifld%value(k,l,n,nf)
             end do
          end do
          call mpi_gatherv (buf2d(1,begpatch), numsend , mpir8, &
               gather2d, numrecvv, displsv, mpir8, 0, mpicom, ier)
          if (masterproc) then
             do l = 1, nlevsoi
                do k = 1, numpatch
                   mlsoifld%value(k,l,n,nf) = gather2d(l,k)  
                end do
             end do
          endif
       end do
       deallocate (buf2d)
       deallocate (gather2d)
    endif
#endif
    if (masterproc) then
       if (hist_dov2xy(nf)) then
          beg4d(1) = 1       ; len4d(1) = lsmlon
          beg4d(2) = 1       ; len4d(2) = lsmlat
          beg4d(3) = 1       ; len4d(3) = nlevsoi
          beg4d(4) = ntim(nf); len4d(4) = 1
          do i = 1, mlsoifld%num(nf)
             do l = 1, nlevsoi
                call v2xy (mlsoifld%value(1,l,i,nf), spval, mlsoifxy(1,1,l))
             end do
             call wrap_put_vara_realx (ncid(nf), mlsoifld_id(i,nf), &
                  beg4d, len4d, mlsoifxy)
          end do
       else
          beg3d(1) = 1        ; len3d(1) = numpatch
          beg3d(2) = 1        ; len3d(2) = nlevsoi
          beg3d(3) = ntim(nf) ; len3d(3) = 1
          do i = 1, mlsoifld%num(nf)
             call wrap_put_vara_realx (ncid(nf), mlsoifld_id(i,nf), &
                  beg3d, len3d, mlsoifld%value(1,1,i,nf))
          end do
       endif
    endif

    return 
  end subroutine histwrt

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

  subroutine histcls (nf)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! close netCDF file 
!
! Method: 
! 
! Author: Gordon Bonan
! 
!-----------------------------------------------------------------------

    include 'netcdf.inc'

! ------------------------ arguments ---------------------------------
    integer, intent(in) :: nf           !history file number
! --------------------------------------------------------------------

    call wrap_close(ncid(nf))

    return
  end subroutine histcls

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

  subroutine histslf (name, fld)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! accumulate single-level field over history time interval
!
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use precision
    use clm_varmap, only : begpatch, endpatch

! ------------------------ arguments ------------------------------
    character(len=*), intent(in) :: name            !field name
    real(r8), intent(in) :: fld(begpatch:endpatch)  !field values for current time step
! -----------------------------------------------------------------

! ------------------------ local variables ------------------------
    integer i,n,m,k     !loop indices
    real(r8), pointer :: value(:)
    integer , pointer :: count(:)
    character(len= 8) :: type
! -----------------------------------------------------------------

    do m = 1, nhist

       ! find field index. return if "name" is not on active list
       n = 0
       do i = 1, slfld%num(m)
          if (name == slfld%nam(i,m)) n = i
       end do
       if (n == 0) go to 1000
     
       ! determine field attributes
       type  =  slfld%typ(n,m)
       value => slfld%value(:,n,m)
       count => slfld%count(:,n,m)
       
!$OMP PARALLEL DO PRIVATE (K)
       do k = begpatch,endpatch
        
          ! accumulate field 
          if (fld(k) /= spval) then
             if (type == naver) then           !time average field
                if (count(k) == 0) value(k) = 0.  
                value(k) = value(k) + fld(k)
                count(k) = count(k) + 1
             else if (type == ncnst) then      !constant field value
                if (count(k) == 0) then
                   value(k) = fld(k)
                   count(k) = 1
                endif
             else if (type == ninst) then      !instantaneous field value
                value(k) = fld(k)
                count(k) = 1
             else if (type == nmaxi) then      !maximum field value
                if (count(k) == 0) value(k) = -1.e50
                value(k) = max( value(k), fld(k) )
                count(k) = 1
             else if (type == nmini) then      !minimum field value
                if (count(k) == 0) value(k) = +1.e50
                value(k) = min( value(k), fld(k) )
                count(k) = 1
             end if
          else
             if (count(k)== 0) value(k) = fld(k)
          endif
          
          ! end of history interval: normalize accumulated values 
          if (ehi(m)) then
             if (type == naver .and. count(k)/=0) then  
                value(k) = value(k) / float(count(k))
             end if
          endif
          
       end do
!$OMP END PARALLEL DO
     
1000   continue
    end do

    return
  end subroutine histslf

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

  subroutine histmlf (name, fld, nlev)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! accumulate multi-level field over history time interval
!
! Method: 
! 
! Author: Mariana Vertenstein
! 
!-----------------------------------------------------------------------

    use precision
    use clm_varmap , only : begpatch, endpatch
    use clm_varpar , only : nlevsoi
  
! ------------------------ arguments ------------------------------
    character(len=*), intent(in) :: name                !field name
    integer , intent(in) :: nlev                        !number of levels
    real(r8), intent(in) :: fld(begpatch:endpatch,nlev) !field values for current time step
! -----------------------------------------------------------------

! ------------------------ local variables ------------------------
    integer i,j,n,m,k         !do loop indices
    real(r8), pointer :: value(:,:)
    integer , pointer :: count(:,:)
    character(len= 8) :: type
! -----------------------------------------------------------------

! loop over history tapes
    
    do m = 1, nhist
       
       ! find field index. return if "name" is not on active list
       n = 0
       do i = 1, mlsoifld%num(m)
          if (name == mlsoifld%nam(i,m)) n = i
       end do
       if (n == 0) go to 1000
       
       ! initialize field attributes
       type  =  mlsoifld%typ(n,m)
       value => mlsoifld%value(:,:,n,m)
       count => mlsoifld%count(:,:,n,m)
       
!$OMP PARALLEL DO PRIVATE (J,K)
       do k = begpatch,endpatch
          do j = 1, nlev
           
             ! accumulate field 
             if (fld(k,j) /= spval) then
                if (type == naver) then           !time average field
                   if (count(k,j) == 0) value(k,j) = 0.  
                   value(k,j) = value(k,j) + fld(k,j)
                   count(k,j) = count(k,j) + 1
                else if (type == ncnst) then      !constant field value
                   if (count(k,j) == 0) then
                      value(k,j) = fld(k,j)
                      count(k,j) = 1
                   endif
                else if (type == ninst) then      !instantaneous field value
                   value(k,j) = fld(k,j)
                   count(k,j) = 1
                else if (type == nmaxi) then      !maximum field value
                   if (count(k,j) == 0) value(k,j) = -spval
                   value(k,j) = max(value(k,j),fld(k,j))
                   count(k,j) = 1
                else if (type == nmini) then      !minimum field value
                   if (count(k,j) == 0) value(k,j) = +spval
                   value(k,j) = min(value(k,j),fld(k,j))
                   count(k,j) = 1
                end if
             else
                if (count(k,j)== 0) value(k,j) = fld(k,j)
             endif
             
             ! end of history interval, normalize accumulated values 
             if (ehi(m)) then
                if (type==naver .and. count(k,j)/=0) then
                   value(k,j) = value(k,j) / float(count(k,j))
                endif
             endif
             
          end do
       end do
!$OMP END PARALLEL DO
     
1000   continue
    end do
  
    return
  end subroutine histmlf

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

  subroutine histzero(nfile)

!----------------------------------------------------------------------- 
! 
! Purpose: 
! zero out history counters
!
!