nf_fwrite3d_bry.F

Go to the documentation of this file.

#include "cppdefs.h"
      MODULE nf_fwrite3d_bry_mod
 
#ifdef ADJUST_BOUNDARY
!
!git $Id$
!================================================== Hernan G. Arango ===
!  Copyright (c) 2002-2025 The ROMS Group                              !
!    Licensed under a MIT/X style license                              !
!    See License_ROMS.md                                               !
!=======================================================================
!                                                                      !
!  This function writes out a generic floating point 3D boundary array !
!  into an output file using either the standard NetCDF library or the !
!  Parallel-IO (PIO) library.                                          !
!                                                                      !
!  On Input:                                                           !
!                                                                      !
!     ng           Nested grid number (integer)                        !
!     model        Calling model identifier (integer)                  !
!     ncname       NetCDF output file name (string)                    !
!     ncvname      NetCDF variable name (string)                       !
!     ncid         NetCDF file ID (integer)                            !
# if defined PIO_LIB && defined DISTRIBUTE
!or   pioFile      PIO file descriptor structure, TYPE(file_desc_t)    !
!                    pioFile%fh         file handler                   !
!                    pioFile%iosystem   IO system descriptor (struct)  !
# endif
!     ncvarid      NetCDF variable ID (integer)                        !
# if defined PIO_LIB && defined DISTRIBUTE
!or   pioVar       PIO variable descriptor structure, TYPE(My_VarDesc) !
!                    pioVar%vd     variable descriptor TYPE(Var_Desc_t)!
!                    pioVar%dkind  variable data kind                  !
!                    pioVar%gtype  variable C-gridtype                 !
# endif
!     tindex       NetCDF time record index to write (integer)         !
!     gtype        Grid type (integer)                                 !
# if defined PIO_LIB && defined DISTRIBUTE
!or   pioDesc      IO data decomposition descriptor, TYPE(IO_desc_t)   !
# endif
!     LBij         IJ-dimension lower bound (integer)                  !
!     UBij         IJ-dimension upper bound (integer)                  !
!     LBk          K-dimension lower bound (integer)                   !
!     UBk          K-dimension upper bound (integer)                   !
!     Nrec         Number of boundary records (integer)                !
!     Ascl         Factor to scale field before writing (real)         !
!     Abry         Boundary field to write out (real)                  !
!     ExtractField Field extraction flag (integer, OPTIONAL)           !
!                    ExtractField = 0   no extraction                  !
!                    ExtractField = 1   extraction by interpolation    !
!                    ExtractField > 1   extraction by decimation       !
!                                                                      !
!  On Output:                                                          !
!                                                                      !
!     status       Error flag (integer).                               !
!     MinValue     Minimum value (real, OPTIONAL)                      !
!     MaxValue     Maximum value (real, OPTIONAL)                      !
!                                                                      !
# ifdef POSITIVE_ZERO
!  Starting F95 zero values can be signed (-0 or +0) following the     !
!  IEEE 754 floating point standard.  This may produce different       !
!  output data in serial and parallel applications. Since comparing    !
!  serial and parallel output is essential for tracking parallel       !
!  partition bugs, "positive zero" is enforced.                        !
!                                                                      !
# endif
!=======================================================================
!
      USE mod_param
      USE mod_parallel
      USE mod_ncparam
      USE mod_scalars
!
# ifdef DISTRIBUTE
      USE distribute_mod, ONLY : mp_bcasti, mp_collect
#  endif
      USE pack_field_mod, ONLY : pack_boundary3d
!
      implicit none
!
      INTERFACE nf_fwrite3d_bry
        MODULE PROCEDURE nf90_fwrite3d_bry
# if defined PIO_LIB && defined DISTRIBUTE
        MODULE PROCEDURE pio_fwrite3d_bry
# endif
      END INTERFACE nf_fwrite3d_bry
!
      CONTAINS
!
!***********************************************************************
      FUNCTION nf90_fwrite3d_bry (ng, model, ncname, ncid,              &
     &                            ncvname, ncvarid,                     &
     &                            tindex, gtype,                        &
     &                            LBij, UBij, LBk, UBk, Nrec,           &
     &                            Ascl, Abry,                           &
     &                            ExtractField,                         &
     &                            MinValue, MaxValue) RESULT(status)
!***********************************************************************
!
      USE mod_netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, ncid, ncvarid, tindex, gtype
      integer, intent(in) :: lbij, ubij, lbk, ubk, nrec
!
      integer, intent(in), optional :: extractfield
!
      real(dp), intent(in) :: ascl
!
      character (len=*), intent(in) :: ncname
      character (len=*), intent(in) :: ncvname
!
# ifdef ASSUMED_SHAPE
      real(r8), intent(in) :: abry(lbij:,lbk:,:,:)
# else
      real(r8), intent(in) :: abry(lbij:ubij,lbk:ubk,4,nrec)
# endif
      real(r8), intent(out), optional :: minvalue
      real(r8), intent(out), optional :: maxvalue
!
!  Local variable declarations.
!
      integer :: iorj, ijklen, klen, npts, i, tile
      integer :: extract_flag
      integer :: status
 
      integer, dimension(5) :: start, total
!
      real(r8), parameter :: aspv = 0.0_r8
 
      real(r8), dimension((UBij-LBij+1)*(UBk-LBk+1)*4*Nrec) :: awrk
!
!-----------------------------------------------------------------------
!  Initialize local variables.
!-----------------------------------------------------------------------
!
      status=nf90_noerr
!
!  Set parallel tile.
!
#  ifdef DISTRIBUTE
      tile=myrank
#  else
      tile=-1
#  endif
!
!  Set length of boundary data as the value of greater of I- or
!  j-dimension.
!
      iorj=iobounds(ng)%IorJ
      klen=ubk-lbk+1
      ijklen=iorj*klen
      npts=ijklen*4*nrec
!
!  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
!
!  Initialize local array to avoid denormalized numbers. This
!  facilitates processing and debugging.
!
      awrk=0.0_r8
!
!-----------------------------------------------------------------------
!  Pack 2D boundary data into 1D array.
!-----------------------------------------------------------------------
!
      CALL pack_boundary3d (ng, model, tile,                            &
     &                      gtype, ncvname, tindex,                     &
     &                      extract_flag,                               &
     &                      lbij, ubij, lbk, ubk, nrec,                 &
     &                      ascl, abry,                                 &
     &                      start, total, npts, awrk)
!
!-----------------------------------------------------------------------
!  If applicable, compute output field minimum and maximum values.
!-----------------------------------------------------------------------
!
      IF (PRESENT(minvalue)) THEN
        IF (outthread) THEN
          minvalue=spval
          maxvalue=-spval
          DO i=1,npts
            IF (abs(awrk(i)).lt.spval) THEN
              minvalue=min(minvalue,awrk(i))
              maxvalue=max(maxvalue,awrk(i))
            END IF
          END DO
        END IF
      END IF
!
!-----------------------------------------------------------------------
!  Write output buffer into NetCDF file.
!-----------------------------------------------------------------------
!
      status=nf90_noerr
      IF (outthread) THEN
        status=nf90_put_var(ncid, ncvarid, awrk, start, total)
      END IF
 
# ifdef DISTRIBUTE
!
!-----------------------------------------------------------------------
!  Broadcast IO error flag to all nodes.
!-----------------------------------------------------------------------
!
      CALL mp_bcasti (ng, model, status)
# endif
!
      RETURN
      END FUNCTION nf90_fwrite3d_bry
 
# if defined PIO_LIB && defined DISTRIBUTE
!
!***********************************************************************
      FUNCTION pio_fwrite3d_bry (ng, model, ncname, pioFile,            &
     &                           ncvname, pioVar,                       &
     &                           tindex, pioDesc,                       &
     &                           LBij, UBij, LBk, UBk, Nrec,            &
     &                           Ascl, Abry,                            &
     &                           MinValue, MaxValue) RESULT(status)
!***********************************************************************
!
      USE mod_pio_netcdf
!
!  Imported variable declarations.
!
      integer, intent(in) :: ng, model, tindex
      integer, intent(in) :: lbij, ubij, lbk, ubk, nrec
!
      real(dp), intent(in) :: ascl
!
      character (len=*), intent(in) :: ncname
      character (len=*), intent(in) :: ncvname
!
#  ifdef ASSUMED_SHAPE
      real(r8), intent(in) :: abry(lbij:,lbk:,:,:)
#  else
      real(r8), intent(in) :: abry(lbij:ubij,lbk:ubk,4,nrec)
#  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, dimension(4) :: bounded
!
      integer :: bc, i, ib, ic, ir, j, k, kc, rc
      integer :: dkind, gtype, tile
      integer :: iorj, ijklen, imin, imax, jmin, jmax, klen, npts
      integer :: istr, iend, jstr, jend
 
      integer, dimension(5) :: start, total
 
      integer :: status
!
      real(r8), parameter :: aspv = 0.0_r8
 
      real(r8), dimension((UBij-LBij+1)*(UBk-LBk+1)*4*Nrec) :: awrk
!
!-----------------------------------------------------------------------
!  Set starting and ending indices to process.
!-----------------------------------------------------------------------
!
      status=pio_noerr
!
!  Set tile starting and ending bounds.
!
      tile=myrank
      dkind=piovar%dkind
      gtype=piovar%gtype
!
      SELECT CASE (gtype)
        CASE (p2dvar, p3dvar)
          imin=bounds(ng)%Istr (tile)
          imax=bounds(ng)%Iend (tile)
          jmin=bounds(ng)%Jstr (tile)
          jmax=bounds(ng)%Jend (tile)
        CASE (r2dvar, r3dvar)
          imin=bounds(ng)%IstrR(tile)
          imax=bounds(ng)%IendR(tile)
          jmin=bounds(ng)%JstrR(tile)
          jmax=bounds(ng)%JendR(tile)
        CASE (u2dvar, u3dvar)
          imin=bounds(ng)%Istr (tile)
          imax=bounds(ng)%IendR(tile)
          jmin=bounds(ng)%JstrR(tile)
          jmax=bounds(ng)%JendR(tile)
        CASE (v2dvar, v3dvar)
          imin=bounds(ng)%IstrR(tile)
          imax=bounds(ng)%IendR(tile)
          jmin=bounds(ng)%Jstr (tile)
          jmax=bounds(ng)%JendR(tile)
        CASE DEFAULT
          imin=bounds(ng)%IstrR(tile)
          imax=bounds(ng)%IendR(tile)
          jmin=bounds(ng)%JstrR(tile)
          jmax=bounds(ng)%JendR(tile)
      END SELECT
!
      iorj=iobounds(ng)%IorJ
      klen=ubk-lbk+1
      ijklen=iorj*klen
      npts=ijklen*4*nrec
!
!  Get tile bounds.
!
      istr=bounds(ng)%Istr(tile)
      iend=bounds(ng)%Iend(tile)
      jstr=bounds(ng)%Jstr(tile)
      jend=bounds(ng)%Jend(tile)
!
!  Set switch to process boundary data by their associated tiles.
!
      bounded(iwest )=domain(ng)%Western_Edge (tile)
      bounded(ieast )=domain(ng)%Eastern_Edge (tile)
      bounded(isouth)=domain(ng)%Southern_Edge(tile)
      bounded(inorth)=domain(ng)%Northern_Edge(tile)
!
!  Set NetCDF dimension counters for processing requested field.
!
      start(1)=1
      total(1)=iorj
      start(2)=1
      total(2)=klen
      start(3)=1
      total(3)=4
      start(4)=1
      total(4)=nrec
      start(5)=tindex
      total(5)=1
!
!-----------------------------------------------------------------------
!  Pack and scale output data.
!-----------------------------------------------------------------------
!
      awrk=aspv
!
      DO ir=1,nrec
        rc=(ir-1)*ijklen*4
        DO ib=1,4
          IF (bounded(ib)) THEN
            bc=(ib-1)*ijklen+rc
            IF ((ib.eq.iwest).or.(ib.eq.ieast)) THEN
              DO k=lbk,ubk
                kc=(k-lbk)*iorj+bc
                DO j=jmin,jmax
                  ic=1+(j-lbij)+kc
                  awrk(ic)=abry(j,k,ib,ir)*ascl
#  ifdef POSITIVE_ZERO
                  IF (abs(awrk(ic)).eq.0.0_r8) THEN
                    awrk(ic)=0.0_r8               ! impose positive zero
                  END IF
#  endif
                END DO
              END DO
            ELSE IF ((ib.eq.isouth).or.(ib.eq.inorth)) THEN
              DO k=lbk,ubk
                kc=(k-lbk)*iorj+bc
                DO i=imin,imax
                  ic=1+(i-lbij)+kc
                  awrk(ic)=abry(i,k,ib,ir)*ascl
#  ifdef POSITIVE_ZERO
                  IF (abs(awrk(ic)).eq.0.0_r8) THEN
                    awrk(ic)=0.0_r8               ! impose positive zero
                  END IF
#  endif
                END DO
              END DO
            END IF
          END IF
        END DO
      END DO
!
!  Collect data from all spawned processes.
!
      CALL mp_collect (ng, model, npts, aspv, awrk)
!
!-----------------------------------------------------------------------
!  If applicable, compute output field minimum and maximum values.
!-----------------------------------------------------------------------
!
      IF (PRESENT(minvalue)) THEN
        minvalue=spval
        maxvalue=-spval
        DO i=1,npts
          IF (abs(awrk(i)).lt.spval) THEN
            minvalue=min(minvalue,awrk(i))
            maxvalue=max(maxvalue,awrk(i))
          END IF
        END DO
      END IF
!
!-----------------------------------------------------------------------
!  Write output buffer into NetCDF file.
!-----------------------------------------------------------------------
!
      status=pio_put_var(piofile, piovar%vd, start, total, awrk)
!
      RETURN
      END FUNCTION pio_fwrite3d_bry
# endif
#endif
      END MODULE nf_fwrite3d_bry_mod