MAPL_CFIOWriteBundlePost

public subroutine MAPL_CFIOWriteBundlePost(MCFIO, PrePost, RC)

The subroutine MAPL_CFIOWriteBundlePost writes an ESMF Bundle to a File. Only the MAPL_CFIO object is a required argument as pointers to the actual data to be written is recorded in it during creation.

CLOCK, BUNDLE can be used to override the choice made at creation, but this is of dubious value, particularly for BUNDLE since it must be excatly conformant with the creation BUNDLE. NBITS if the number of bits of the mantissa to retain. This is used to write files with degraded precision, which can then be compressed with standard utilities. The default is no degradation of precision.

A note about compression. NetCDF-4, HDF-4 and HDF-5 all support transparent internal GZIP compression of the data being written. However, very little is gained by compressing float point fields from earth system models. Compression yields can be greatly increased by setting to zero bits in the mantissa of float numbers. On average 50\% compression can be achieved, while preserving a meaningful accuracy in the fields. Unlike classical CF compression by means of scale_factor and add_offset attributes, internal GZIP compression requires no special handling by the users of the data. In fact, they do not even need to know that the data is compressed! At this point, MAPL_CFIO does not activate this GZIP compression feature in the files being written, but the resulting precision degredaded files can be compressed offline with the HDF-4 hrepack utility.

Arguments

Type	Intent	Optional		Name
type(MAPL_CFIO),	intent(inout)		::	MCFIO
logical,	intent(in),	optional	::	PrePost
integer,	intent(out),	optional	::	RC

Source Code

  subroutine MAPL_CFIOWriteBundlePost( MCFIO, PrePost, RC )
!
    type(MAPL_CFIO  ),               intent(INOUT) :: MCFIO
    logical,               optional, intent(IN   ) :: PrePost
    integer,               optional, intent(  OUT) :: RC

    integer                    :: status

    type(ESMF_FIELD)           :: FIELD
    integer                    :: L, K, k0, LM
    integer                    :: NN
    real,             pointer  :: Ptr2(:,:), Ptr3(:,:,:)
    real, target, allocatable  :: Ple3d(:,:,:)
    real,         allocatable  :: Pl3d(:,:,:)
    real,         allocatable  :: Ptrx(:,:,:)
    real,             pointer  :: layer(:,:),ps0(:,:)
    logical                    :: PrePost_
    integer                    :: globalcount(3)
    type(ESMF_VM)              :: vm
!                              ---
    _ASSERT(MCFIO%CREATED, 'MCFIO%CREATED is false')

    if (present(PrePost)) then
       PrePost_ = PrePost
    else
       PrePost_ = .true.
    end if

!  Set centers and edges of interpolating field
!----------------------------------------------

    if(mCFIO%Vinterp) then
       call ESMF_FieldBundleGet(mCFIO%bundle, fieldName=mCFIO%Vvar, Field=Field,  RC=STATUS)
       _VERIFY(STATUS)

       nullify (ptr3)
       call ESMF_FieldGet(Field, localDE=0, farrayPtr=Ptr3, rc=status)
       _VERIFY(STATUS)

       allocate( LAYER(size(Ptr3,1),size(Ptr3,2) ), stat=status)
       _VERIFY(STATUS)

       if (associated(mcfio%regridder)) then
          call ESMF_VMGetCurrent(vm,rc=status)
          _VERIFY(status)
          call MAPL_GridGet(mcfio%grid,globalCellCountPerDim=globalCount,rc=status)
          _VERIFY(status)
          call MAPL_AllocNodeArray(ps0,[globalCount(1),globalCount(2)],rc=status)
          if(STATUS==MAPL_NoShm) allocate(ps0(globalCount(1),globalCount(2)),stat=status)
          _VERIFY(status)
          call MAPL_AllocNodeArray(mcfio%surfaceLayer,[mcfio%im,mcfio%jm],rc=status)
          if(STATUS==MAPL_NoShm) allocate(mcfio%surfaceLayer(mcfio%im,mcfio%jm),stat=status)
          _VERIFY(STATUS)
       end if

! The Ptr3 interpolating variable is a zero-based (0-LM) edge variable
!---------------------------------------------------------------------
       if(lbound(PTR3,3)==0) then
          allocate( ple3D(size(Ptr3,1),size(Ptr3,2),size(Ptr3,3)  ), stat=status)
          _VERIFY(STATUS)
          allocate(  pl3D(size(Ptr3,1),size(Ptr3,2),size(Ptr3,3)-1), stat=status)
          _VERIFY(STATUS)

          if    (mCFIO%Func=='log') then
             ple3D = log(Ptr3)
             pl3D  = log( 0.5*(Ptr3(:,:,1:)+Ptr3(:,:,0:ubound(Ptr3,3)-1)) )
          elseif(mCFIO%Func=='pow') then
             ple3D = Ptr3**mCFIO%pow
             pl3D  =    ( 0.5*(Ptr3(:,:,1:)+Ptr3(:,:,0:ubound(Ptr3,3)-1)) )**mCFIO%pow
          else
             ple3D = Ptr3
             pl3D  =    ( 0.5*(Ptr3(:,:,1:)+Ptr3(:,:,0:ubound(Ptr3,3)-1)) )
          end if
          if (associated(mCFIO%regridder)) then
             mcfio%ascending = (ptr3(1,1,0)<ptr3(1,1,1))
             call ArrayGather(ptr3(:,:,ubound(ptr3,3)),ps0,mcfio%grid,rc=status)
             _VERIFY(status)
          end if

       else

! The Ptr3 interpolating variable is a (1-LM) mid-layer variable
!---------------------------------------------------------------
          allocate(  Ptrx(size(Ptr3,1),size(Ptr3,2),0:size(Ptr3,3)  ), stat=status)
          _VERIFY(STATUS)
          allocate( ple3D(size(Ptr3,1),size(Ptr3,2),0:size(Ptr3,3)  ), stat=status)
          _VERIFY(STATUS)
          allocate(  pl3D(size(Ptr3,1),size(Ptr3,2),  size(Ptr3,3)  ), stat=status)
          _VERIFY(STATUS)

          Ptrx(:,:,0               ) = 0.5*( 3* Ptr3(:,:,1)             -Ptr3(:,:,2)                )
          Ptrx(:,:,1:size(Ptr3,3)-1) = 0.5*(    Ptr3(:,:,2:size(Ptr3,3))+Ptr3(:,:,1:size(Ptr3,3)-1) )
          Ptrx(:,:,  size(Ptr3,3)  ) = 0.5*( 3* Ptr3(:,:,  size(Ptr3,3))-Ptr3(:,:,  size(Ptr3,3)-1) )

          if    (mCFIO%Func=='log') then
             ple3D = log(Ptrx)
             pl3D  = log( 0.5*(Ptrx(:,:,1:)+Ptrx(:,:,0:ubound(Ptrx,3)-1)) )
          elseif(mCFIO%Func=='pow') then
             ple3D = Ptrx**mCFIO%pow
             pl3D  =    ( 0.5*(Ptrx(:,:,1:)+Ptrx(:,:,0:ubound(Ptrx,3)-1)) )**mCFIO%pow
          else
             ple3D = Ptrx
             pl3D  =    ( 0.5*(Ptrx(:,:,1:)+Ptrx(:,:,0:ubound(Ptrx,3)-1)) )
          end if

          if (associated(mCFIO%regridder)) then
             mcfio%ascending = (ptrx(1,1,0)<ptrx(1,1,1))
             call ArrayGather(ptrx(:,:,ubound(ptrx,3)),ps0,mcfio%grid,rc=status)
             _VERIFY(status)

          end if
          deallocate(Ptrx)
       end if

       if (associated(mCFIO%regridder)) then
          call MAPL_BcastShared(vm,data=ps0,N=globalCount(1)*globalCount(2),root=0,RootOnly=.false.,rc=status)
          _VERIFY(status)
          if (MAPL_AmNodeRoot .or. (.not. MAPL_ShmInitialized)) then
             call mCFIO%regridder%regrid(ps0,mcfio%surfaceLayer,rc=status)
             _VERIFY(status)
          end if

          if (MAPL_ShmInitialized) then
             call MAPL_DeAllocNodeArray(ps0,rc=status)
             _VERIFY(status)
          else
             deallocate(ps0)
          end if
       end if

    end if

    call MAPL_CFIOSetVectorPairs(mCFIO,rc=status)
    _VERIFY(status)

! Cycle through all variables posting receives.
!----------------------------------------------

    nn = 0

    POSTRECV: do L=1, size(MCFIO%VarDims)
       if    (mCFIO%VarDims(L)==2) then ! Rank == 2
          LM = 1
       elseif(MCFIO%VarDims(L)==3) then ! Rank == 3
          LM = MCFIO%LM
       else
          LM = 0
       endif

       do K=1,LM
          nn    = nn + 1
          call MAPL_CreateRequest(MCFIO%GRID, MCFIO%Krank(nn), MCFIO%reqs(nn), &
                                  tag=nn, RequestType=MAPL_IsGather, PrePost = PrePost_, RC=STATUS)
          _VERIFY(STATUS)
       enddo
    end do POSTRECV

! Cycle through all variables posting sends.
!-------------------------------------------

    nn = 0

    VARIABLES: do L=1, size(MCFIO%VarDims)

       call ESMF_FieldBundleGet(MCFIO%BUNDLE, MCFIO%VARNAME(L), FIELD=FIELD,                  RC=STATUS)
       _VERIFY(STATUS)

! We treat only fields with rank 2 (horizontal 2D) and
!  rank 3 (first 2 dimension are horz, third is vert).
!--------------------------------------------------------

       RANK: if (MCFIO%VarDims(L)==2) then ! Rank == 2

          nn    = nn + 1
          ptr2  =>null()

          call ESMF_FieldGet      (FIELD, localDE=0, farrayPtr=PTR2, RC=STATUS)
          _VERIFY(STATUS)
          call MAPL_ArrayIGather  (Ptr2, MCFIO%reqs(NN), RC=STATUS)
          _VERIFY(STATUS)

       elseif(MCFIO%VarDims(L)==3) then ! Rank == 3

          ptr3 =>null()

          call ESMF_FieldGet      (FIELD, localDE=0, farrayPtr=PTR3, RC=STATUS)
          _VERIFY(STATUS)

          K0  = lbound(PTR3,3) - 1

! For each level, interpolate vertically and post gather
!-------------------------------------------------------

          LAYERS: do K=1,MCFIO%LM
             VINTERP: if(mCFIO%Vinterp) then
                call VertInterp(LAYER, PTR3, MCFIO%LEVS(K), ple3d, pl3d, rc=status)
                _VERIFY(STATUS)
             else if (MCFIO%LEVS(K)<0) then
                LAYER => PTR3(:,:,K+K0)
             else
                LAYER => PTR3(:,:,nint(MCFIO%LEVS(K)))
             end if VINTERP

             nn    = nn + 1

             call MAPL_ArrayIGather(LAYER, MCFIO%reqs(nn), rc=status)
             _VERIFY(STATUS)
          enddo LAYERS

       end if RANK

    end do VARIABLES



!   if(mCFIO%myPE==mCFIO%Root) then
!      print *, ' Posted to File: ', trim(mCFIO%fName)
!   endif


    if(mCFIO%Vinterp) then
       deallocate( ple3D, stat=status)
       _VERIFY(STATUS)
       deallocate( pl3D , stat=status)
       _VERIFY(STATUS)
       deallocate( Layer, stat=status)
       _VERIFY(STATUS)
    end if

    _RETURN(ESMF_SUCCESS)
  end subroutine MAPL_CFIOWriteBundlePost

MAPL_CFIOWriteBundlePost Subroutine

Contents

Source Code

public subroutine MAPL_CFIOWriteBundlePost(MCFIO, PrePost, RC)

Arguments

Calls

Source Code