nf_fwrite3d_mod::nf_fwrite3d Interface Reference

Public Member Functions
integer function	nf90_fwrite3d (ng, model, ncid, ifield, ncvarid, tindex, gtype, lbi, ubi, lbj, ubj, lbk, ubk, ascl, amask, adat, setfillval, extractfield, minvalue, maxvalue)
integer function	pio_fwrite3d (ng, model, piofile, ifield, piovar, tindex, piodesc, lbi, ubi, lbj, ubj, lbk, ubk, ascl, amask, adat, setfillval, extractfield, minvalue, maxvalue)

Detailed Description

Definition at line 78 of file nf_fwrite3d.F.

Member Function/Subroutine Documentation

nf90_fwrite3d()

integer function nf_fwrite3d_mod::nf_fwrite3d::nf90_fwrite3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		integer, intent(in)	ncid,
		integer, intent(in)	ifield,
		integer, intent(in)	ncvarid,
		integer, intent(in)	tindex,
		integer, intent(in)	gtype,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		real(dp), intent(in)	ascl,
		real(r8), dimension(lbi:,lbj:), intent(in)	amask,
		real(r8), dimension(lbi:,lbj:,lbk:), intent(in)	adat,
		logical, intent(in), optional	setfillval,
		integer, intent(in), optional	extractfield,
		real(r8), intent(out), optional	minvalue,
		real(r8), intent(out), optional	maxvalue )

Definition at line 90 of file nf_fwrite3d.F.

!***********************************************************************
!
      USE mod_netcdf
 
# if defined WRITE_WATER && defined MASKING
!
      USE distribute_mod, ONLY : mp_collect
# endif
      USE get_bounds_mod, ONLY : tile_bounds_1d
!
!  Imported variable declarations.
!
      logical, intent(in), optional :: SetFillVal
!
      integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
      integer, intent(in) :: ifield
      integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
!
      integer, intent(in), optional :: ExtractField
!
      real(dp), intent(in) :: Ascl
!
# ifdef ASSUMED_SHAPE
#  ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:,LBj:)
#  endif
      real(r8), intent(in) :: Adat(LBi:,LBj:,LBk:)
# else
#  ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
#  endif
      real(r8), intent(in) :: Adat(LBi:UBi,LBj:UBj,LBk:UBk)
# endif
      real(r8), intent(out), optional :: MinValue
      real(r8), intent(out), optional :: MaxValue
!
!  Local variable declarations.
!
      logical :: LandFill
!
      integer :: Extract_Flag
      integer :: i, ic, j, jc, k, kc, Npts
      integer :: Imin, Imax, Jmin, Jmax
      integer :: Ioff, Joff, Koff
      integer :: Istr, Iend
      integer :: Ilen, Isize, Jlen, Jsize, IJlen, Klen
      integer :: MyType
      integer :: status
 
      integer, dimension(4) :: start, total
!
      real(r8), parameter :: IniVal = 0.0_r8
 
      real(r8), allocatable :: Awrk(:)
!
!-----------------------------------------------------------------------
!  Set starting and ending indices to process.
!-----------------------------------------------------------------------
!
      status=nf90_noerr
!
!  Set first and last grid point according to staggered C-grid
!  classification.
!
      mytype=gtype
!
      SELECT CASE (abs(mytype))
        CASE (p2dvar, p3dvar)
          imin=bounds(ng)%Istr (myrank)
          imax=bounds(ng)%IendR(myrank)
          jmin=bounds(ng)%Jstr (myrank)
          jmax=bounds(ng)%JendR(myrank)
          isize=iobounds(ng)%xi_psi
          jsize=iobounds(ng)%eta_psi
        CASE (r2dvar, r3dvar)
          imin=bounds(ng)%IstrR(myrank)
          imax=bounds(ng)%IendR(myrank)
          jmin=bounds(ng)%JstrR(myrank)
          jmax=bounds(ng)%JendR(myrank)
          isize=iobounds(ng)%xi_rho
          jsize=iobounds(ng)%eta_rho
        CASE (u2dvar, u3dvar)
          imin=bounds(ng)%Istr (myrank)
          imax=bounds(ng)%IendR(myrank)
          jmin=bounds(ng)%JstrR(myrank)
          jmax=bounds(ng)%JendR(myrank)
          isize=iobounds(ng)%xi_u
          jsize=iobounds(ng)%eta_u
        CASE (v2dvar, v3dvar)
          imin=bounds(ng)%IstrR(myrank)
          imax=bounds(ng)%IendR(myrank)
          jmin=bounds(ng)%Jstr (myrank)
          jmax=bounds(ng)%JendR(myrank)
          isize=iobounds(ng)%xi_v
          jsize=iobounds(ng)%eta_v
        CASE DEFAULT
          imin=bounds(ng)%IstrR(myrank)
          imax=bounds(ng)%IendR(myrank)
          jmin=bounds(ng)%JstrR(myrank)
          jmax=bounds(ng)%JendR(myrank)
          isize=iobounds(ng)%xi_rho
          jsize=iobounds(ng)%eta_rho
      END SELECT
!
      ilen=imax-imin+1
      jlen=jmax-jmin+1
      klen=ubk-lbk+1
!
!  Set switch to replace land areas with fill value, spval.
!
# ifdef MASKING
      IF (PRESENT(setfillval)) THEN
        landfill=setfillval
      ELSE
        landfill=tindex.gt.0
      END IF
# else
      landfill=.false.
# endif
!
!  If appropriate, set the field extraction flag to the provided grid
!  geometry through interpolation or decimation.
!
      IF (PRESENT(extractfield)) THEN
        extract_flag=extractfield
      ELSE
        extract_flag=0
      END IF
!
!-----------------------------------------------------------------------
!  Parallel I/O: Pack tile data into 1D array in column-major order.
# ifdef MASKING
!                Overwrite masked points with special value.
# endif
!-----------------------------------------------------------------------
!
      IF (gtype.gt.0) THEN
!
!  Set offsets due the NetCDF dimensions. Recall that some output
!  variables not always start at one.
!
        SELECT CASE (abs(mytype))
          CASE (p2dvar, p3dvar)
            ioff=0
            joff=0
          CASE (r2dvar, r3dvar)
            ioff=1
            joff=1
          CASE (u2dvar, u3dvar)
            ioff=0
            joff=1
          CASE (v2dvar, v3dvar)
            ioff=1
            joff=0
          CASE DEFAULT
            ioff=1
            joff=1
        END SELECT
!
        IF (lbk.eq.0) THEN
          koff=1
        ELSE
          koff=0
        END IF
!
!  Allocate and initialize scratch work array.
!
        ijlen=ilen*jlen
        npts=ijlen*klen
 
        IF (.not.allocated(awrk)) THEN
          allocate ( awrk(npts) )
          awrk=inival
        END IF
!
!  Pack and scale tile data.
!
        ic=0
        DO k=lbk,ubk
          DO j=jmin,jmax
            DO i=imin,imax
              ic=ic+1
              awrk(ic)=adat(i,j,k)*ascl
# ifdef POSITIVE_ZERO
              IF (abs(awrk(ic)).eq.0.0_r8) THEN
                awrk(ic)=0.0_r8                   ! impose positive zero
              END IF
# endif
# ifdef MASKING
              IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
                awrk(ic)=spval
              END IF
# endif
            END DO
          END DO
        END DO
!
!  Write out data: all parallel nodes write their own packed tile data.
!
        start(1)=imin+ioff
        total(1)=ilen
        start(2)=jmin+joff
        total(2)=jlen
        start(3)=lbk+koff
        total(3)=klen
        start(4)=tindex
        total(4)=1
 
        status=nf90_put_var(ncid, ncvarid, awrk, start, total)
      END IF
 
# if defined WRITE_WATER && defined MASKING
!
!-----------------------------------------------------------------------
!  Parallel I/O: Remove land points and pack tile data into 1D array.
!-----------------------------------------------------------------------
!
      IF (gtype.lt.0) THEN
!
!  Set offsets due array packing into 1D array in column-major order.
!
        SELECT CASE (abs(mytype))
          CASE (p2dvar, p3dvar)
            ioff=0
            joff=1
          CASE (r2dvar, r3dvar)
            ioff=1
            joff=0
          CASE (u2dvar, u3dvar)
            ioff=0
            joff=0
          CASE (v2dvar, v3dvar)
            ioff=1
            joff=1
          CASE DEFAULT
            ioff=1
            joff=0
        END SELECT
 
        IF (lbk.eq.0) THEN
          koff=0
        ELSE
          koff=1
        END IF
!
!  Allocate and initialize scratch work array.
!
        ijlen=isize*jsize
        npts=ijlen*klen
 
        IF (.not.allocated(awrk)) THEN
          allocate ( awrk(npts) )
          awrk=inival
        END IF
!
!  Scale and gather data from all spawned nodes. Store data into a 1D
!  global array, packed in column-major order. Flag land point with
!  special value.
!
        DO k=lbk,ubk
          kc=(k-koff)*ijlen
          DO j=jmin,jmax
            jc=(j-joff)*isize+kc
            DO i=imin,imax
              ic=i+ioff+jc
              awrk(ic)=adat(i,j,k)*ascl
#  ifdef POSITIVE_ZERO
              IF (abs(awrk(ic)).eq.0.0_r8) THEN
                awrk(ic)=0.0_r8                   ! impose positive zero
              END IF
#  endif
              IF (amask(i,j).eq.0.0_r8) THEN
                awrk(ic)=spval
              END IF
            END DO
          END DO
        END DO
!
!  Global reduction of work array.
!
        CALL mp_collect (ng, model, npts, inival, awrk)
!
!  Remove land points.
!
        ic=0
        DO i=1,npts
          IF (awrk(i).lt.spval) THEN
            ic=ic+1
            awrk(ic)=awrk(i)
          END IF
        END DO
        npts=ic
!
!  Write out data: all parallel nodes write a section of the packed
!                  data.
!
        CALL tile_bounds_1d (ng, myrank, npts, istr, iend)
 
        start(1)=istr
        total(1)=iend-istr+1
        start(2)=tindex
        total(2)=1
 
        status=nf90_put_var(ncid, ncvarid, awrk(istr:), start, total)
      END IF
# endif
!
!-----------------------------------------------------------------------
!  Deallocate scratch work array.
!-----------------------------------------------------------------------
!
      IF (allocated(awrk)) THEN
        deallocate (awrk)
      END IF
!
      RETURN

References mod_param::bounds, mod_param::iobounds, distribute_mod::mp_gather2d(), distribute_mod::mp_gather3d(), mod_parallel::myrank, mod_parallel::outthread, mod_param::p2dvar, mod_param::p3dvar, pack_field_mod::pack_field3d(), mod_param::r2dvar, mod_param::r3dvar, mod_scalars::spval, stats_mod::stats_3dfld(), get_bounds_mod::tile_bounds_1d(), mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, and mod_ncparam::vname.

Here is the call graph for this function:

pio_fwrite3d()

integer function nf_fwrite3d_mod::nf_fwrite3d::pio_fwrite3d	(	integer, intent(in)	ng,
		integer, intent(in)	model,
		type (file_desc_t), intent(inout)	piofile,
		integer, intent(in)	ifield,
		type (my_vardesc), intent(inout)	piovar,
		integer, intent(in)	tindex,
		type (io_desc_t), intent(inout)	piodesc,
		integer, intent(in)	lbi,
		integer, intent(in)	ubi,
		integer, intent(in)	lbj,
		integer, intent(in)	ubj,
		integer, intent(in)	lbk,
		integer, intent(in)	ubk,
		real(dp), intent(in)	ascl,
		real(r8), dimension(lbi:,lbj:), intent(in)	amask,
		real(r8), dimension(lbi:,lbj:,lbk:), intent(in)	adat,
		logical, intent(in), optional	setfillval,
		integer, intent(in), optional	extractfield,
		real(r8), intent(out), optional	minvalue,
		real(r8), intent(out), optional	maxvalue )

Definition at line 623 of file nf_fwrite3d.F.

!***********************************************************************
!
      USE mod_pio_netcdf
!
      USE distribute_mod, ONLY : mp_reduce
# ifdef OUTPUT_STATS
      USE stats_mod,      ONLY : stats_3dfld
# endif
!
!  Imported variable declarations.
!
      logical, intent(in), optional :: SetFillVal
!
      integer, intent(in) :: ng, model, tindex
      integer, intent(in) :: ifield
      integer, intent(in) :: LBi, UBi, LBj, UBj, LBk, UBk
!
      integer, intent(in), optional :: ExtractField
!
      real(dp), intent(in) :: Ascl
!
# ifdef ASSUMED_SHAPE
#  ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:,LBj:)
#  endif
      real(r8), intent(in) :: Adat(LBi:,LBj:,LBk:)
# else
#  ifdef MASKING
      real(r8), intent(in) :: Amask(LBi:UBi,LBj:UBj)
#  endif
      real(r8), intent(in) :: Adat(LBi:UBi,LBj:UBj,LBk:UBk)
# endif
      real(r8), intent(out), optional :: MinValue
      real(r8), intent(out), optional :: MaxValue
!
      TYPE (File_desc_t), intent(inout) :: pioFile
      TYPE (IO_Desc_t),   intent(inout) :: pioDesc
      TYPE (My_VarDesc),  intent(inout) :: pioVar
!
!  Local variable declarations.
!
      logical :: LandFill, Lminmax
 
      logical, pointer :: Lwater(:,:,:)
!
      integer :: Extract_Flag
      integer :: i, j, k, tile
      integer :: Imin, Imax, Jmin, Jmax
      integer :: Cgrid, dkind, ghost, gtype
      integer :: status
 
      integer, dimension(4) :: start, total
!
      real(r8), dimension(2) :: rbuffer
 
      real(r4), pointer :: Awrk4(:,:,:)
      real(r8), pointer :: Awrk8(:,:,:)
 
# ifdef OUTPUT_STATS
!
      TYPE (T_STATS) :: Stats
# endif
!
      character (len= 3), dimension(2) :: op_handle
!
!-----------------------------------------------------------------------
!  Set starting and ending indices to process.
!-----------------------------------------------------------------------
!
      status=pio_noerr
!
!  Set first and last grid point according to staggered C-grid
!  classification. Set loops offsets.
!
      ghost=0
      dkind=piovar%dkind
      gtype=piovar%gtype
!
      SELECT CASE (abs(gtype))
        CASE (p2dvar, p3dvar)
          cgrid=1
        CASE (b3dvar, l3dvar, r2dvar, r3dvar)
          cgrid=2
        CASE (u2dvar, u3dvar)
          cgrid=3
        CASE (v2dvar, v3dvar)
          cgrid=4
        CASE DEFAULT
          cgrid=2
      END SELECT
!
      imin=bounds(ng)%Imin(cgrid,ghost,myrank)
      imax=bounds(ng)%Imax(cgrid,ghost,myrank)
      jmin=bounds(ng)%Jmin(cgrid,ghost,myrank)
      jmax=bounds(ng)%Jmax(cgrid,ghost,myrank)
!
!  Set switch to compute minimum and maximum values.
!
      IF (PRESENT(minvalue)) THEN
        lminmax=.true.
        IF (.not.associated(lwater)) THEN
          allocate ( lwater(lbi:ubi,lbj:ubj,lbk:ubk) )
          lwater=.true.
        END IF
      ELSE
        lminmax=.false.
      END IF
!
!  Set switch to replace land areas with fill value, spval.
!
# ifdef MASKING
      IF (PRESENT(setfillval)) THEN
        landfill=setfillval
      ELSE
        landfill=tindex.gt.0
      END IF
# else
      landfill=.false.
# endif
!
!  If appropriate, set the field extraction flag to the provided grid
!  geometry through interpolation or decimation.
!
      IF (PRESENT(extractfield)) THEN
        extract_flag=extractfield
      ELSE
        extract_flag=0
      END IF
 
# ifdef OUTPUT_STATS
!
!  Initialize output variable statistics structure.
!
      stats % checksum=0_i8b
      stats % count=0
      stats % min=spval
      stats % max=-spval
      stats % avg=0.0_r8
      stats % rms=0.0_r8
# endif
!
!-----------------------------------------------------------------------
!  Write out data into NetCDF file.
!-----------------------------------------------------------------------
!
!  Allocate, initialize and load data into local array used for
!  writing. Overwrite masked points with special value.
!
      IF (dkind.eq.pio_double) THEN                 ! double precision
        IF (.not.associated(awrk8)) THEN
          allocate ( awrk8(lbi:ubi,lbj:ubj,lbk:ubk) )
          awrk8=0.0_r8
        END IF
!
        DO k=lbk,ubk
          DO j=jmin,jmax
            DO i=imin,imax
              awrk8(i,j,k)=adat(i,j,k)*ascl
# ifdef MASKING
              IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
                awrk8(i,j,k)=spval
                IF (lminmax) lwater(i,j,k)=.false.
              END IF
# endif
            END DO
          END DO
        END DO
        IF (lminmax) THEN
          rbuffer(1)=minval(awrk8, mask=lwater)
          rbuffer(2)=maxval(awrk8, mask=lwater)
        END IF
      ELSE                                          ! single precision
        IF (.not.associated(awrk4)) THEN
          allocate ( awrk4(lbi:ubi,lbj:ubj,lbk:ubk) )
          awrk4=0.0_r4
        END IF
!
        DO k=lbk,ubk
          DO j=jmin,jmax
            DO i=imin,imax
              awrk4(i,j,k)=real(adat(i,j,k)*ascl, r4)
# ifdef MASKING
              IF ((amask(i,j).eq.0.0_r8).and.landfill) THEN
                awrk4(i,j,k)=real(spval, r4)
              END IF
# endif
            END DO
          END DO
        END DO
        IF (lminmax) THEN
          rbuffer(1)=real(minval(awrk4, mask=lwater),r8)
          rbuffer(2)=real(maxval(awrk4, mask=lwater),r8)
        END IF
      END IF
!
!  Set unlimited time dimension record to write, if any.
!
      IF (tindex.gt.0) THEN
        CALL pio_setframe (piofile,                                     &
     &                     piovar%vd,                                   &
     &                     int(tindex, kind=pio_offset_kind))
      END IF
!
!  Write out data into NetCDF.
!
      IF (dkind.eq.pio_double) THEN                 ! double precision
        CALL pio_write_darray (piofile,                                 &
     &                         piovar%vd,                               &
     &                         piodesc,                                 &
     &                         awrk8(imin:imax,jmin:jmax,lbk:ubk),      &
     &                         status)
      ELSE                                          ! single precision
        CALL pio_write_darray (piofile,                                 &
     &                         piovar%vd,                               &
     &                         piodesc,                                 &
     &                         awrk4(imin:imax,jmin:jmax,lbk:ubk),      &
     &                         status)
      END IF
 
# ifdef OUTPUT_STATS
!
!-----------------------------------------------------------------------
!  Compute and report output field statistics.
!-----------------------------------------------------------------------
!
#  ifdef DISTRIBUTE
      tile=myrank
#  else
      tile=-1
#  endif
      CALL stats_3dfld (ng, tile, model, gtype, stats,                  &
     &                  extract_flag,                                   &
     &                  lbi, ubi, lbj, ubj, lbk, ubk,                   &
     &                  adat,                                           &
#  ifdef MASKING
     &                  fmask = amask,                                  &
#  endif
     &                  extract_flag = extract_flag,                    &
     &                  debug = .false.)
      IF (outthread) THEN
        WRITE (stdout,10) trim(vname(1,ifield)), stats%min, stats%max,  &
     &                    stats%checksum
  10    FORMAT (4x,'- ',a,':',t35,'Min = ',1p,e15.8,',  Max = ',        &
     &          1p,e15.8,',  CheckSum = ',i0)
      END IF
# endif
!
!-----------------------------------------------------------------------
!  If applicable, compute global minimum and maximum values.
!-----------------------------------------------------------------------
!
      IF (lminmax) THEN
        op_handle(1)='MIN'
        op_handle(2)='MAX'
        CALL mp_reduce (ng, model, 2, rbuffer, op_handle)
        minvalue=rbuffer(1)
        maxvalue=rbuffer(2)
        IF (associated(lwater)) deallocate (lwater)
      END IF
!
!  Deallocate local array.
!
      IF (dkind.eq.pio_double) THEN
        IF (associated(awrk8)) deallocate (awrk8)
      ELSE
        IF (associated(awrk4)) deallocate (awrk4)
      END IF
!
      RETURN

References mod_param::b3dvar, mod_param::bounds, mod_param::l3dvar, mod_parallel::myrank, mod_parallel::outthread, mod_param::p2dvar, mod_param::p3dvar, mod_param::r2dvar, mod_param::r3dvar, mod_scalars::spval, stats_mod::stats_3dfld(), mod_param::u2dvar, mod_param::u3dvar, mod_param::v2dvar, mod_param::v3dvar, and mod_ncparam::vname.

Here is the call graph for this function:

---

The documentation for this interface was generated from the following file:

• ROMS/Utility/nf_fwrite3d.F