/wrfv2_fire/frame/module_quilt_outbuf_ops.F

Large files files are truncated, but you can click here to view the full file

MODULE module_quilt_outbuf_ops
!<DESCRIPTION>
!<PRE>
! This module contains routines and data structures used by the I/O quilt 
! servers to assemble fields ("quilting") and write them to disk.  
!</PRE>
!</DESCRIPTION>
  INTEGER, PARAMETER :: tabsize = 5
  ! The number of entries in outpatch_table (up to a maximum of tabsize)
  INTEGER, SAVE      :: num_entries

! ARP, for PNC-enabled quilting, 02/06/2010
  TYPE varpatch
    LOGICAL                            :: forDeletion ! TRUE if patch to be 
                                                      ! deleted
    INTEGER, DIMENSION(3)              :: PatchStart, PatchEnd, PatchExtent
    REAL,    POINTER, DIMENSION(:,:,:) :: rptr 
    INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
  END TYPE varpatch

  ! With PNC-enabled quilting, each table entry consists of a series of
  ! 'npatch' patches (one for each of the compute PEs that this IOServer has
  ! as clients). We attempt to stitch these together before finally 
  ! writing the data to disk.
  TYPE outpatchlist
    CHARACTER*80                       :: VarName, DateStr, MemoryOrder, &
                                          Stagger, DimNames(3)
    INTEGER, DIMENSION(3)              :: DomainStart, DomainEnd
    INTEGER                            :: FieldType
    ! Total no. of patches in the list PatchList
    INTEGER                            :: nPatch
    ! How many of the patches remain active in PatchList
    INTEGER                            :: nActivePatch
    TYPE(varpatch), ALLOCATABLE, DIMENSION(:) :: PatchList
!    TYPE(varpatch), DIMENSION(tabsize) :: PatchList
  END TYPE outpatchlist

  TYPE(outpatchlist), DIMENSION(tabsize), SAVE :: outpatch_table

  ! List of which of the initial set of patches saved by the IOServer have 
  ! been successfully stitched together. Without any stitching, each patch's 
  ! entry contains just itself:
  !   JoinedPatches(1,ipatch) = ipatch
  ! If jpatch is then stitched to ipatch then we do:
  !   JoinedPatches(2,ipatch) = jpatch
  ! and so on.
  INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: JoinedPatches 
 
  ! The no. of original patches to be stitched together to make each new patch
  ! i.e. if the 2nd new patch consists of 4 of the original patches stitched
  ! together then:
  !   PatchCount(2) = 4
  INTEGER, ALLOCATABLE, DIMENSION(:), SAVE   :: PatchCount

! endARP, for PNC-enabled quilting, 02/06/2010

  TYPE outrec
    CHARACTER*80                       :: VarName, DateStr, MemoryOrder, &
                                          Stagger, DimNames(3)
    INTEGER                            :: ndim
    INTEGER, DIMENSION(3)              :: DomainStart, DomainEnd
    INTEGER                            :: FieldType
    REAL,    POINTER, DIMENSION(:,:,:) :: rptr 
    INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
  END TYPE outrec

  TYPE(outrec), DIMENSION(tabsize) :: outbuf_table

CONTAINS

  SUBROUTINE init_outbuf
!<DESCRIPTION>
!<PRE>
! This routine re-initializes module data structures.  
!</PRE>
!</DESCRIPTION>
    IMPLICIT NONE
    INTEGER :: i, j
    DO i = 1, tabsize

#ifdef PNETCDF_QUILT
      ! This section for PNC-enabled IO quilting
      outpatch_table(i)%VarName = ""
      outpatch_table(i)%DateStr = ""
      outpatch_table(i)%MemoryOrder = ""
      outpatch_table(i)%Stagger = ""
      outpatch_table(i)%DimNames(1:3) = ""
      outpatch_table(i)%DomainStart(1:3) = 0
      outpatch_table(i)%DomainEnd(1:3)   = 0
      ! We don't free any memory here - that is done immediately after the
      ! write of each patch is completed
      DO j = 1, outpatch_table(i)%npatch
         outpatch_table(i)%PatchList(j)%forDeletion   = .FALSE.
         outpatch_table(i)%PatchList(j)%PatchStart(:) = 0
         outpatch_table(i)%PatchList(j)%PatchEnd(:)   = 0
         outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0
         IF (ALLOCATED(outpatch_table(i)%PatchList)) THEN
            IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%rptr)) &
               NULLIFY( outpatch_table(i)%PatchList(j)%rptr )
            IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%iptr)) &
               NULLIFY( outpatch_table(i)%PatchList(j)%iptr )
            DEALLOCATE(outpatch_table(i)%PatchList)
         ENDIF
      END DO
      outpatch_table(i)%npatch           = 0
      outpatch_table(i)%nActivePatch     = 0
#else
      outbuf_table(i)%VarName = ""
      outbuf_table(i)%DateStr = ""
      outbuf_table(i)%MemoryOrder = ""
      outbuf_table(i)%Stagger = ""
      outbuf_table(i)%DimNames(1) = ""
      outbuf_table(i)%DimNames(2) = ""
      outbuf_table(i)%DimNames(3) = ""
      outbuf_table(i)%ndim = 0
      NULLIFY( outbuf_table(i)%rptr )
      NULLIFY( outbuf_table(i)%iptr )
#endif

    ENDDO
write(0,*)'initializing num_entries to 0 '
    num_entries = 0
  END SUBROUTINE init_outbuf

#ifdef PNETCDF_QUILT
  SUBROUTINE write_outbuf_pnc ( DataHandle, io_form_arg, local_comm, &
                                mytask, ntasks )
!<DESCRIPTION>
!<PRE>
! This routine writes all of the records stored in outpatch_table to the 
! file referenced by DataHandle using pNetCDF. The patches constituting
! each record are stitched together as far as is possible before
! the pNetCDF I/O routines are called to accomplish the write.
! 
! It then re-initializes module data structures.  
!</PRE>
!</DESCRIPTION>
    USE module_state_description
    IMPLICIT NONE
    INCLUDE 'mpif.h'
#include "wrf_io_flags.h"
    INTEGER , INTENT(IN)  :: DataHandle, io_form_arg, &
                             local_comm, mytask, ntasks
    INTEGER               :: ii, jj
    INTEGER               :: DomainDesc ! dummy
    INTEGER               :: Status
    INTEGER               :: ipatch, icnt
    INTEGER, ALLOCATABLE, DIMENSION(:) :: count_buf
    INTEGER               :: min_count
    LOGICAL               :: do_indep_write ! If no. of patches differs between
                                            ! IO Servers then we will have to 
                                            ! switch pnetcdf into 
                                            ! independent-writes mode for some 
                                            ! of them
    CHARACTER*256         :: mess

    DomainDesc = 0 

    ALLOCATE(count_buf(ntasks), Stat=Status)
    IF(Status /= 0)THEN
       CALL wrf_error_fatal("write_outbuf_pnc: allocate failed")
    END IF

    WRITE(mess,"('write_outbuf_pnc: table has ', I3,' entries')") num_entries
    CALL wrf_message(mess)

    DO ii = 1, num_entries

      WRITE(mess,*)'write_outbuf_pnc: writing ', &
                    TRIM(outpatch_table(ii)%DateStr)," ",                    &
                    TRIM(outpatch_table(ii)%VarName)," ",                    &
                    TRIM(outpatch_table(ii)%MemoryOrder)
      CALL wrf_message(mess)

      SELECT CASE ( io_form_arg )

        CASE ( IO_PNETCDF   )

          ! Situation is more complicated in this case since field data stored 
          ! as a list of patches rather than in one array of global-domain 
          ! extent.
          ! PatchStart(1) - PatchEnd(1) is dimension with unit stride.

          ! Quilt patches back together where possible in order to minimise 
          ! number of individual writes
          CALL stitch_outbuf_patches(ii)

          ! Check how many patches each of the other IO servers has - we can
          ! only use pNetCDF in collective mode for the same no. of writes
          ! on each IO server. Any other patches will have to be written in
          ! independent mode.
          do_indep_write = .FALSE.
          count_buf(:) = 0
          min_count = outpatch_table(ii)%nActivePatch

          CALL MPI_AllGather(min_count, 1, MPI_INTEGER,      &
	                     count_buf, 1, MPI_INTEGER, &
	                     local_comm, Status)

          ! Work out the minimum no. of patches on any IO Server and whether 
          ! or not we will have to enter independent IO mode.
          min_count = outpatch_table(ii)%nActivePatch
          DO jj=1,ntasks, 1
             IF(count_buf(jj) < min_count) min_count = count_buf(jj)
             IF(outpatch_table(ii)%nActivePatch /= count_buf(jj)) do_indep_write = .TRUE.

          END DO

!          WRITE(mess,*) 'ARPDBG: Min. no. of patches is ', min_count
!          CALL wrf_message(mess)
!          WRITE(mess,*) 'ARPDBG: I have ',count_buf(mytask+1),' patches.'
!          CALL wrf_message(mess)

          IF ( outpatch_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
             
             ! Loop over the patches in this field up to the number that 
             ! every IO Server has. This is slightly tricky now
             ! that some of them may be 'deleted.' 

             ipatch = 0
             icnt = 0
             DO WHILE ( icnt < min_count )

                ipatch = ipatch + 1

                IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE

                icnt = icnt + 1

                WRITE (mess, "('Calling write for patch: ',I3, ' Start = ',3I4)") ipatch, outpatch_table(ii)%PatchList(ipatch)%PatchStart(1:3)
                CALL wrf_message(mess)
                WRITE (mess,"(29x,'End = ',3I4)") outpatch_table(ii)%PatchList(ipatch)%PatchEnd(1:3)
                CALL wrf_message(mess)

                CALL ext_pnc_write_field ( DataHandle ,                          &
                                 TRIM(outpatch_table(ii)%DateStr),               &
                                 TRIM(outpatch_table(ii)%VarName),               &
                                 outpatch_table(ii)%PatchList(ipatch)%rptr,      &
                                 outpatch_table(ii)%FieldType,                   &!*
                                 local_comm, local_comm, DomainDesc ,            &
                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
                                 TRIM(outpatch_table(ii)%Stagger),               &!*
                                 outpatch_table(ii)%DimNames ,                   &!*
                                 outpatch_table(ii)%DomainStart,                 &
                                 outpatch_table(ii)%DomainEnd,                   &
                                 ! ARP supply magic number as MemoryStart and 
                                 ! MemoryEnd to signal that this routine is 
                                 ! being called from quilting.
                                 -998899,                                        &
                                 -998899,                                        &
                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
                                 Status )

                ! Free memory associated with this patch
                DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)

             END DO

             IF( do_indep_write )THEN
                ! We must do the next few patches (if any) in independent IO 
                ! mode as not all of the IO Servers have the same no. of 
                ! patches. 
                ! outpatch_table(ii)%nActivePatch holds the no. of live patches
                ! for this IO Server

                CALL ext_pnc_start_independent_mode(DataHandle, Status)

                DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )

                   ipatch = ipatch + 1

                   IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE

                   icnt = icnt + 1

                   CALL ext_pnc_write_field ( DataHandle ,                          &
                                 TRIM(outpatch_table(ii)%DateStr),               &
                                 TRIM(outpatch_table(ii)%VarName),               &
                                 outpatch_table(ii)%PatchList(ipatch)%rptr,      &
                                 outpatch_table(ii)%FieldType,                   &!*
                                 local_comm, local_comm, DomainDesc ,                      &
                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
                                 TRIM(outpatch_table(ii)%Stagger),               &!*
                                 outpatch_table(ii)%DimNames ,                   &!*
                                 outpatch_table(ii)%DomainStart,                 &
                                 outpatch_table(ii)%DomainEnd,                   &
                                 ! ARP supply magic number as MemoryStart and 
                                 ! MemoryEnd to signal that this routine is 
                                 ! being called from quilting.
                                 -998899,                                        &
                                 -998899,                                        &
                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
                                 Status )

                   ! Free memory associated with this patch
                   DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)

                END DO

                ! End of patches that not every IO Server has so can switch
                ! back to collective mode.
                CALL ext_pnc_end_independent_mode(DataHandle, Status)


             END IF ! Additional patches

          ELSE IF ( outpatch_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN

             ! Loop over the patches in this field up to the number that 
             ! every IO Server has. This is slightly tricky now
             ! that some of them may be 'deleted.' 
             ipatch = 0
             icnt = 0
             DO WHILE ( icnt < min_count )

                ipatch = ipatch + 1

                IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE

                icnt = icnt + 1

                CALL ext_pnc_write_field ( DataHandle ,                           &
                                 TRIM(outpatch_table(ii)%DateStr),                &
                                 TRIM(outpatch_table(ii)%VarName),                &
                                 outpatch_table(ii)%PatchList(ipatch)%iptr,       &
                                 outpatch_table(ii)%FieldType,                    &!*
                                 local_comm, local_comm, DomainDesc,              &
                                 TRIM(outpatch_table(ii)%MemoryOrder),            &
                                 TRIM(outpatch_table(ii)%Stagger),                &!*
                                 outpatch_table(ii)%DimNames ,                    &!*
                                 outpatch_table(ii)%DomainStart,                  &
                                 outpatch_table(ii)%DomainEnd,                    &
                                 ! ARP supply magic number as MemoryStart and 
                                 ! MemoryEnd to signal that this routine is 
                                 ! being called from quilting.
                                 -998899,                                         &
                                 -998899,                                         &
                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart, &
                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,   &
                                 Status )

                ! Free memory associated with this patch
                DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)

             END DO

             IF( do_indep_write )THEN

                ! We have to do the next few patches in independent IO mode as 
                ! not all of the IO Servers have this many patches. 
                ! outpatch_table(ii)%npatch holds the no. of live patches for 
                ! this IO Server
                CALL ext_pnc_start_independent_mode(DataHandle, Status)

                DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )

                   ipatch = ipatch + 1

                   IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE

                   icnt = icnt + 1

                   CALL ext_pnc_write_field ( DataHandle ,                          &
                                 TRIM(outpatch_table(ii)%DateStr),               &
                                 TRIM(outpatch_table(ii)%VarName),               &
                                 outpatch_table(ii)%PatchList(ipatch)%iptr,      &
                                 outpatch_table(ii)%FieldType,                   &!*
                                 local_comm, local_comm, DomainDesc ,                      &
                                 TRIM(outpatch_table(ii)%MemoryOrder),           &
                                 TRIM(outpatch_table(ii)%Stagger),               &!*
                                 outpatch_table(ii)%DimNames ,                   &!*
                                 outpatch_table(ii)%DomainStart,                 &
                                 outpatch_table(ii)%DomainEnd,                   &
                                 ! ARP supply magic number as MemoryStart and 
                                 ! MemoryEnd to signal that this routine is 
                                 ! being called from quilting.
                                 -998899,                                        &
                                 -998899,                                        &
                                 outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
                                 outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
                                 Status )

                   ! Free memory associated with this patch
                   DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)

                END DO

                ! End of patches that not every IO Server has so can switch
                ! back to collective mode.
                CALL ext_pnc_end_independent_mode(DataHandle, Status)

             ENDIF ! Have additional patches
          ENDIF

        CASE DEFAULT
      END SELECT

    ENDDO ! Loop over output buffers

    ! Reset the table of output buffers
    CALL init_outbuf()

    DEALLOCATE(count_buf)

  END SUBROUTINE write_outbuf_pnc
#endif

  SUBROUTINE write_outbuf ( DataHandle , io_form_arg )
!<DESCRIPTION>
!<PRE>
! This routine writes all of the records stored in outbuf_table to the 
! file referenced by DataHandle using format specified by io_form_arg.  
! This routine calls the package-specific I/O routines to accomplish 
! the write.  
! It then re-initializes module data structures.  
!</PRE>
!</DESCRIPTION>
    USE module_state_description
    IMPLICIT NONE
#include "wrf_io_flags.h"
    INTEGER , INTENT(IN)  :: DataHandle, io_form_arg
    INTEGER               :: ii,ds1,de1,ds2,de2,ds3,de3
    INTEGER               :: Comm, IOComm, DomainDesc ! dummy
    INTEGER               :: Status
    CHARACTER*256         :: mess
    Comm = 0 ; IOComm = 0 ; DomainDesc = 0 

    DO ii = 1, num_entries
      WRITE(mess,*)'writing ', &
                    TRIM(outbuf_table(ii)%DateStr)," ",                                   &
                    TRIM(outbuf_table(ii)%VarName)," ",                                   &
                    TRIM(outbuf_table(ii)%MemoryOrder)
      ds1 = outbuf_table(ii)%DomainStart(1) ; de1 = outbuf_table(ii)%DomainEnd(1)
      ds2 = outbuf_table(ii)%DomainStart(2) ; de2 = outbuf_table(ii)%DomainEnd(2)
      ds3 = outbuf_table(ii)%DomainStart(3) ; de3 = outbuf_table(ii)%DomainEnd(3)

      SELECT CASE ( io_form_arg )

#ifdef NETCDF
        CASE ( IO_NETCDF   )

          IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN

          CALL ext_ncd_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
          CALL ext_ncd_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )
          ENDIF
#endif
#ifdef YYY
      CASE ( IO_YYY   )

          IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN

          CALL ext_yyy_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
          CALL ext_yyy_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )
          ENDIF
#endif
#ifdef GRIB1
      CASE ( IO_GRIB1   )

          IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN

          CALL ext_gr1_write_field ( DataHandle ,                                   &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
          CALL ext_gr1_write_field ( DataHandle ,                                   &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )
          ENDIF
#endif
#ifdef GRIB2
      CASE ( IO_GRIB2   )

          IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN

          CALL ext_gr2_write_field ( DataHandle ,                                   &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
          CALL ext_gr2_write_field ( DataHandle ,                                   &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )
          ENDIF
#endif
#ifdef INTIO
        CASE ( IO_INTIO  )
          IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN

          CALL ext_int_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN

          CALL ext_int_write_field ( DataHandle ,                                     &
                                 TRIM(outbuf_table(ii)%DateStr),                      &
                                 TRIM(outbuf_table(ii)%VarName),                      &
                                 outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
                                 outbuf_table(ii)%FieldType,                          &  !*
                                 Comm, IOComm, DomainDesc ,                           &
                                 TRIM(outbuf_table(ii)%MemoryOrder),                  &
                                 TRIM(outbuf_table(ii)%Stagger),                      &  !*
                                 outbuf_table(ii)%DimNames ,                          &  !*
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 outbuf_table(ii)%DomainStart,                        &
                                 outbuf_table(ii)%DomainEnd,                          &
                                 Status )

          ENDIF
#endif
        CASE DEFAULT
      END SELECT


      IF ( ASSOCIATED( outbuf_table(ii)%rptr) ) DEALLOCATE(outbuf_table(ii)%rptr)
      IF ( ASSOCIATED( outbuf_table(ii)%iptr) ) DEALLOCATE(outbuf_table(ii)%iptr)
      NULLIFY( outbuf_table(ii)%rptr )
      NULLIFY( outbuf_table(ii)%iptr )
    ENDDO
    CALL init_outbuf
  END SUBROUTINE write_outbuf


  SUBROUTINE stitch_outbuf_patches(ibuf)
    USE module_timing
    IMPLICIT none
    INTEGER, INTENT(in) :: ibuf
!<DESCRIPTION>
!<PRE>
! This routine does the "output quilting" for the case where quilting has been
! built to use Parallel NetCDF. Unlike store_patch_in_outbuf() we do not have
! data for the whole domain --- instead we aim to quilt as much of the data as
! possible in order to reduce the number of separate writes that we must do.
!</PRE>
!</DESCRIPTION>
#include "wrf_io_flags.h"
    INTEGER                              :: ipatch, jpatch, ii
    INTEGER                              :: ierr
    INTEGER                              :: npatches
    INTEGER,              DIMENSION(3)   :: newExtent, pos
    INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OldPatchStart
    INTEGER, POINTER,   DIMENSION(:,:,:) :: ibuffer
    REAL,    POINTER,   DIMENSION(:,:,:) :: rbuffer
    CHARACTER*256                        :: mess
integer i,j

!    CALL start_timing()

    IF(LEN_TRIM(outpatch_table(ibuf)%MemoryOrder) < 2)THEN
       ! This field is a scalar or 1D array. Such quantities are replicated
       ! across compute nodes and therefore we need only keep a single
       ! patch - delete all but the first in the list
      IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN

          DO jpatch=2,outpatch_table(ibuf)%npatch,1
             outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
             outpatch_table(ibuf)%nActivePatch = &
                                 outpatch_table(ibuf)%nActivePatch - 1
             DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%rptr)
          END DO

      ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN

          DO jpatch=2,outpatch_table(ibuf)%npatch,1
             outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
             outpatch_table(ibuf)%nActivePatch = &
                                 outpatch_table(ibuf)%nActivePatch - 1
             DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%iptr)
          END DO

      ELSE
         CALL wrf_error_fatal("stitch_outbuf_patches: unrecognised Field Type")
      END IF

!     CALL end_timing("stitch_outbuf_patches: deleting replicated patches")

      RETURN

    END IF ! Field is scalar or 1D

    ! Otherwise, this field _is_ distributed across compute PEs and therefore
    ! it's worth trying to stitch patches together...
    ALLOCATE(OldPatchStart(3,outpatch_table(ibuf)%npatch), &
             JoinedPatches(outpatch_table(ibuf)%npatch,    &
                           outpatch_table(ibuf)%npatch),   &
             PatchCount(outpatch_table(ibuf)%npatch),      &
             Stat=ierr)
    IF(ierr /= 0)THEN
       CALL wrf_message('stitch_outbuf_patches: unable to stitch patches as allocate failed.')
       RETURN
    END IF

    JoinedPatches(:,:) = -1
    ! Initialise these arrays to catch failures in the above allocate on
    ! linux-based systems (e.g. Cray XE) where allocation only actually 
    ! performed when requested memory is touched.
    PatchCount(:) = 0
    OldPatchStart(:,:) = 0

    NULLIFY(ibuffer)
    NULLIFY(rbuffer)

    DO jpatch=1,outpatch_table(ibuf)%npatch,1

       ! Each patch consists of just itself initially
       JoinedPatches(1,jpatch) = jpatch
       PatchCount(jpatch) = 1

       ! Store the location of each patch for use after we've decided how to 
       ! stitch them together
       OldPatchStart(:,jpatch) = outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:)
    END DO

    ! Search through patches to find pairs that we can stitch together
    ipatch = 1
    OUTER: DO WHILE(ipatch < outpatch_table(ibuf)%npatch)

       IF( outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
          ipatch = ipatch + 1
          CYCLE OUTER
       END IF

       INNER: DO jpatch=ipatch+1,outpatch_table(ibuf)%npatch,1

          IF(outpatch_table(ibuf)%PatchList(jpatch)%forDeletion )THEN
             CYCLE INNER
          END IF

          ! Look for patches that can be concatenated with ipatch in the first
          ! dimension (preferred since that is contiguous in memory in F90)
          !  ________________         ____________  
          !  |               |        |           |
          ! Startx(j)     Endx(j) Startx(i)   Endx(i)
          !
          IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
              (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) - 1) )THEN

             ! Patches contiguous in first dimension - do they have the same
             ! extents in the other two dimensions?
             IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
		
                ! We can concatenate these two patches in first dimension
!                WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
!                CALL wrf_message(mess)

                ! Grow patch ipatch to include jpatch
                outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) = &
                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)
                CALL merge_patches(ibuf, ipatch, jpatch)

                ! Go again...
                ipatch = 1
                CYCLE OUTER
             END IF
          END IF
          !  ______________         ____________  
          !  |             |        |           |
          ! Startx(i)    Endx(i) Startx(j)   Endx(j)
          !
          IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1) == &
             (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) + 1))THEN

             ! Patches contiguous in first dimension - do they have the same
             ! extents in the other two dimensions?
             IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN

                 ! We can concatenate these two patches in first dimension
!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
!                 CALL wrf_message(mess)

		! Grow patch ipatch to include jpatch
                outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) = &
                        outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)
                CALL merge_patches(ibuf, ipatch, jpatch)

                ! Go again...
		ipatch = 1
		CYCLE OUTER
              END IF
           END IF

           ! Try the second dimension
           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
                (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) - 1))THEN

              ! Patches contiguous in second dimension - do they have the same
              ! extents in the other two dimensions?
              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN

                 ! We can concatenate these two patches in second dimension
!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
!                 CALL wrf_message(mess)

                 ! Grow patch ipatch to include jpatch
                 outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) = &
                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)
                 CALL merge_patches(ibuf, ipatch, jpatch)

                 ! Go again...
                 ipatch = 1
                 CYCLE OUTER
              END IF
           END IF

           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2) == &
                (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) + 1) )THEN

              ! Patches contiguous in second dimension - do they have the same
              ! extents in the other two dimensions?
              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN

                 ! We can concatenate these two patches in second dimension
!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
!                 CALL wrf_message(mess)

                 ! Grow patch ipatch to include jpatch
                 outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) = &
                         outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)
                 CALL merge_patches(ibuf, ipatch, jpatch)

                 ! Go again...
                 ipatch = 1
                 CYCLE OUTER                 
              END IF
           END IF

           ! Try the third dimension
           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
               (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) - 1) )THEN

              ! Patches contiguous in second dimension - do they have the same
              ! extents in the other two dimensions?
              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN

                 ! We can concatenate these two patches in the third dimension
!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
!                 CALL wrf_message(mess)

                 ! Grow patch ipatch to include jpatch
                 outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) = &
                         outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)
                 CALL merge_patches(ibuf, ipatch, jpatch)

                 ! Go again...
                 ipatch = 1
                 CYCLE OUTER                 
              END IF
           END IF

           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3) == &
                (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) + 1))THEN

              ! Patches contiguous in second dimension - do they have the same
              ! extents in the other two dimensions?
              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
                 (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
		 (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN

                 ! We can concatenate these two patches in the third dimension
!                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
!                 CALL wrf_message(mess)

                 ! Grow patch ipatch to include jpatch
                 outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) = &
                         outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
                 CALL merge_patches(ibuf, ipatch, jpatch)

                 ! Go again...
                 ipatch = 1
                 CYCLE OUTER                 
              END IF
           END IF

       END DO INNER

       ipatch = ipatch + 1

    END DO OUTER

    npatches = 0

    DO jpatch=1,outpatch_table(ibuf)%npatch,1

       IF ( outpatch_table(ibuf)%PatchList(jpatch)%forDeletion ) CYCLE

!       WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch, outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
!             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1),   &
!             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
!             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2),   &
!             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
!             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
!       CALL wrf_message(mess)

       ! Count how many patches we're left with
       npatches = npatches + 1

       ! If no patches have been merged together to make this patch then we 
       ! don't have to do any more with it
       IF(PatchCount(jpatch) == 1) CYCLE

       ! Get the extent of this patch
       newExtent(:) = outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(:) - &
                      outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
       ! Allocate a buffer to hold all of its data
       IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
          ALLOCATE(rbuffer(newExtent(1), newExtent(2), newExtent(3)), &
                   Stat=ierr)
       ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
          ALLOCATE(ibuffer(newExtent(1), newExtent(2), newExtent(3)), &
                   Stat=ierr)
       END IF
       IF(ierr /= 0)THEN
          CALL wrf_error_fatal('stitch_outbuf_patches: unable to stitch patches as allocate for merge buffe…