wrfv2_fire/frame/module_quilt_outbuf_ops.F

   1 MODULE module_quilt_outbuf_ops
   2 !<DESCRIPTION>
   3 !<PRE>
   4 ! This module contains routines and data structures used by the I/O quilt
   5 ! servers to assemble fields ("quilting") and write them to disk.
   6 !</PRE>
   7 !</DESCRIPTION>
   8   INTEGER, PARAMETER :: tabsize = 5
   9   ! The number of entries in outpatch_table (up to a maximum of tabsize)
  10   INTEGER, SAVE      :: num_entries
  11
  12 ! ARP, for PNC-enabled quilting, 02/06/2010
  13   TYPE varpatch
  14     LOGICAL                            :: forDeletion ! TRUE if patch to be
  15                                                       ! deleted
  16     INTEGER, DIMENSION(3)              :: PatchStart, PatchEnd, PatchExtent
  17     REAL,    POINTER, DIMENSION(:,:,:) :: rptr
  18     INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
  19   END TYPE varpatch
  20
  21   ! With PNC-enabled quilting, each table entry consists of a series of
  22   ! 'npatch' patches (one for each of the compute PEs that this IOServer has
  23   ! as clients). We attempt to stitch these together before finally
  24   ! writing the data to disk.
  25   TYPE outpatchlist
  26     CHARACTER*80                       :: VarName, DateStr, MemoryOrder, &
  27                                           Stagger, DimNames(3)
  28     INTEGER, DIMENSION(3)              :: DomainStart, DomainEnd
  29     INTEGER                            :: FieldType
  30     ! Total no. of patches in the list PatchList
  31     INTEGER                            :: nPatch
  32     ! How many of the patches remain active in PatchList
  33     INTEGER                            :: nActivePatch
  34     TYPE(varpatch), ALLOCATABLE, DIMENSION(:) :: PatchList
  35 !    TYPE(varpatch), DIMENSION(tabsize) :: PatchList
  36   END TYPE outpatchlist
  37
  38   TYPE(outpatchlist), DIMENSION(tabsize), SAVE :: outpatch_table
  39
  40   ! List of which of the initial set of patches saved by the IOServer have
  41   ! been successfully stitched together. Without any stitching, each patch's
  42   ! entry contains just itself:
  43   !   JoinedPatches(1,ipatch) = ipatch
  44   ! If jpatch is then stitched to ipatch then we do:
  45   !   JoinedPatches(2,ipatch) = jpatch
  46   ! and so on.
  47   INTEGER, ALLOCATABLE, DIMENSION(:,:), SAVE :: JoinedPatches
  48
  49   ! The no. of original patches to be stitched together to make each new patch
  50   ! i.e. if the 2nd new patch consists of 4 of the original patches stitched
  51   ! together then:
  52   !   PatchCount(2) = 4
  53   INTEGER, ALLOCATABLE, DIMENSION(:), SAVE   :: PatchCount
  54
  55 ! endARP, for PNC-enabled quilting, 02/06/2010
  56
  57   TYPE outrec
  58     CHARACTER*80                       :: VarName, DateStr, MemoryOrder, &
  59                                           Stagger, DimNames(3)
  60     INTEGER                            :: ndim
  61     INTEGER, DIMENSION(3)              :: DomainStart, DomainEnd
  62     INTEGER                            :: FieldType
  63     REAL,    POINTER, DIMENSION(:,:,:) :: rptr
  64     INTEGER, POINTER, DIMENSION(:,:,:) :: iptr
  65   END TYPE outrec
  66
  67   TYPE(outrec), DIMENSION(tabsize) :: outbuf_table
  68
  69 CONTAINS
  70
  71   SUBROUTINE init_outbuf
  72 !<DESCRIPTION>
  73 !<PRE>
  74 ! This routine re-initializes module data structures.
  75 !</PRE>
  76 !</DESCRIPTION>
  77     IMPLICIT NONE
  78     INTEGER :: i, j
  79     DO i = 1, tabsize
  80
  81 #ifdef PNETCDF_QUILT
  82       ! This section for PNC-enabled IO quilting
  83       outpatch_table(i)%VarName = ""
  84       outpatch_table(i)%DateStr = ""
  85       outpatch_table(i)%MemoryOrder = ""
  86       outpatch_table(i)%Stagger = ""
  87       outpatch_table(i)%DimNames(1:3) = ""
  88       outpatch_table(i)%DomainStart(1:3) = 0
  89       outpatch_table(i)%DomainEnd(1:3)   = 0
  90       ! We don't free any memory here - that is done immediately after the
  91       ! write of each patch is completed
  92       DO j = 1, outpatch_table(i)%npatch
  93          outpatch_table(i)%PatchList(j)%forDeletion   = .FALSE.
  94          outpatch_table(i)%PatchList(j)%PatchStart(:) = 0
  95          outpatch_table(i)%PatchList(j)%PatchEnd(:)   = 0
  96          outpatch_table(i)%PatchList(j)%PatchExtent(:)= 0
  97          IF (ALLOCATED(outpatch_table(i)%PatchList)) THEN
  98             IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%rptr)) &
  99                NULLIFY( outpatch_table(i)%PatchList(j)%rptr )
 100             IF (ASSOCIATED(outpatch_table(i)%PatchList(j)%iptr)) &
 101                NULLIFY( outpatch_table(i)%PatchList(j)%iptr )
 102             DEALLOCATE(outpatch_table(i)%PatchList)
 103          ENDIF
 104       END DO
 105       outpatch_table(i)%npatch           = 0
 106       outpatch_table(i)%nActivePatch     = 0
 107 #else
 108       outbuf_table(i)%VarName = ""
 109       outbuf_table(i)%DateStr = ""
 110       outbuf_table(i)%MemoryOrder = ""
 111       outbuf_table(i)%Stagger = ""
 112       outbuf_table(i)%DimNames(1) = ""
 113       outbuf_table(i)%DimNames(2) = ""
 114       outbuf_table(i)%DimNames(3) = ""
 115       outbuf_table(i)%ndim = 0
 116       NULLIFY( outbuf_table(i)%rptr )
 117       NULLIFY( outbuf_table(i)%iptr )
 118 #endif
 119
 120     ENDDO
 121 write(0,*)'initializing num_entries to 0 '
 122     num_entries = 0
 123   END SUBROUTINE init_outbuf
 124
 125 #ifdef PNETCDF_QUILT
 126   SUBROUTINE write_outbuf_pnc ( DataHandle, io_form_arg, local_comm, &
 127                                 mytask, ntasks )
 128 !<DESCRIPTION>
 129 !<PRE>
 130 ! This routine writes all of the records stored in outpatch_table to the
 131 ! file referenced by DataHandle using pNetCDF. The patches constituting
 132 ! each record are stitched together as far as is possible before
 133 ! the pNetCDF I/O routines are called to accomplish the write.
 134 !
 135 ! It then re-initializes module data structures.
 136 !</PRE>
 137 !</DESCRIPTION>
 138     USE module_state_description
 139     IMPLICIT NONE
 140     INCLUDE 'mpif.h'
 141 #include "wrf_io_flags.h"
 142     INTEGER , INTENT(IN)  :: DataHandle, io_form_arg, &
 143                              local_comm, mytask, ntasks
 144     INTEGER               :: ii, jj
 145     INTEGER               :: DomainDesc ! dummy
 146     INTEGER               :: Status
 147     INTEGER               :: ipatch, icnt
 148     INTEGER, ALLOCATABLE, DIMENSION(:) :: count_buf
 149     INTEGER               :: min_count
 150     LOGICAL               :: do_indep_write ! If no. of patches differs between
 151                                             ! IO Servers then we will have to
 152                                             ! switch pnetcdf into
 153                                             ! independent-writes mode for some
 154                                             ! of them
 155     CHARACTER*256         :: mess
 156
 157     DomainDesc = 0
 158
 159     ALLOCATE(count_buf(ntasks), Stat=Status)
 160     IF(Status /= 0)THEN
 161        CALL wrf_error_fatal("write_outbuf_pnc: allocate failed")
 162     END IF
 163
 164     WRITE(mess,"('write_outbuf_pnc: table has ', I3,' entries')") num_entries
 165     CALL wrf_message(mess)
 166
 167     DO ii = 1, num_entries
 168
 169       WRITE(mess,*)'write_outbuf_pnc: writing ', &
 170                     TRIM(outpatch_table(ii)%DateStr)," ",                    &
 171                     TRIM(outpatch_table(ii)%VarName)," ",                    &
 172                     TRIM(outpatch_table(ii)%MemoryOrder)
 173       CALL wrf_message(mess)
 174
 175       SELECT CASE ( io_form_arg )
 176
 177         CASE ( IO_PNETCDF   )
 178
 179           ! Situation is more complicated in this case since field data stored
 180           ! as a list of patches rather than in one array of global-domain
 181           ! extent.
 182           ! PatchStart(1) - PatchEnd(1) is dimension with unit stride.
 183
 184           ! Quilt patches back together where possible in order to minimise
 185           ! number of individual writes
 186           CALL stitch_outbuf_patches(ii)
 187
 188           ! Check how many patches each of the other IO servers has - we can
 189           ! only use pNetCDF in collective mode for the same no. of writes
 190           ! on each IO server. Any other patches will have to be written in
 191           ! independent mode.
 192           do_indep_write = .FALSE.
 193           count_buf(:) = 0
 194           min_count = outpatch_table(ii)%nActivePatch
 195
 196           CALL MPI_AllGather(min_count, 1, MPI_INTEGER,      &
 197                              count_buf, 1, MPI_INTEGER, &
 198                              local_comm, Status)
 199
 200           ! Work out the minimum no. of patches on any IO Server and whether
 201           ! or not we will have to enter independent IO mode.
 202           min_count = outpatch_table(ii)%nActivePatch
 203           DO jj=1,ntasks, 1
 204              IF(count_buf(jj) < min_count) min_count = count_buf(jj)
 205              IF(outpatch_table(ii)%nActivePatch /= count_buf(jj)) do_indep_write = .TRUE.
 206
 207           END DO
 208
 209 !          WRITE(mess,*) 'ARPDBG: Min. no. of patches is ', min_count
 210 !          CALL wrf_message(mess)
 211 !          WRITE(mess,*) 'ARPDBG: I have ',count_buf(mytask+1),' patches.'
 212 !          CALL wrf_message(mess)
 213
 214           IF ( outpatch_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 215
 216              ! Loop over the patches in this field up to the number that
 217              ! every IO Server has. This is slightly tricky now
 218              ! that some of them may be 'deleted.'
 219
 220              ipatch = 0
 221              icnt = 0
 222              DO WHILE ( icnt < min_count )
 223
 224                 ipatch = ipatch + 1
 225
 226                 IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
 227
 228                 icnt = icnt + 1
 229
 230                 WRITE (mess, "('Calling write for patch: ',I3, ' Start = ',3I4)") ipatch, outpatch_table(ii)%PatchList(ipatch)%PatchStart(1:3)
 231                 CALL wrf_message(mess)
 232                 WRITE (mess,"(29x,'End = ',3I4)") outpatch_table(ii)%PatchList(ipatch)%PatchEnd(1:3)
 233                 CALL wrf_message(mess)
 234
 235                 CALL ext_pnc_write_field ( DataHandle ,                          &
 236                                  TRIM(outpatch_table(ii)%DateStr),               &
 237                                  TRIM(outpatch_table(ii)%VarName),               &
 238                                  outpatch_table(ii)%PatchList(ipatch)%rptr,      &
 239                                  outpatch_table(ii)%FieldType,                   &!*
 240                                  local_comm, local_comm, DomainDesc ,            &
 241                                  TRIM(outpatch_table(ii)%MemoryOrder),           &
 242                                  TRIM(outpatch_table(ii)%Stagger),               &!*
 243                                  outpatch_table(ii)%DimNames ,                   &!*
 244                                  outpatch_table(ii)%DomainStart,                 &
 245                                  outpatch_table(ii)%DomainEnd,                   &
 246                                  ! ARP supply magic number as MemoryStart and
 247                                  ! MemoryEnd to signal that this routine is
 248                                  ! being called from quilting.
 249                                  -998899,                                        &
 250                                  -998899,                                        &
 251                                  outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
 252                                  outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
 253                                  Status )
 254
 255                 ! Free memory associated with this patch
 256                 DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
 257
 258              END DO
 259
 260              IF( do_indep_write )THEN
 261                 ! We must do the next few patches (if any) in independent IO
 262                 ! mode as not all of the IO Servers have the same no. of
 263                 ! patches.
 264                 ! outpatch_table(ii)%nActivePatch holds the no. of live patches
 265                 ! for this IO Server
 266
 267                 CALL ext_pnc_start_independent_mode(DataHandle, Status)
 268
 269                 DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
 270
 271                    ipatch = ipatch + 1
 272
 273                    IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
 274
 275                    icnt = icnt + 1
 276
 277                    CALL ext_pnc_write_field ( DataHandle ,                          &
 278                                  TRIM(outpatch_table(ii)%DateStr),               &
 279                                  TRIM(outpatch_table(ii)%VarName),               &
 280                                  outpatch_table(ii)%PatchList(ipatch)%rptr,      &
 281                                  outpatch_table(ii)%FieldType,                   &!*
 282                                  local_comm, local_comm, DomainDesc ,                      &
 283                                  TRIM(outpatch_table(ii)%MemoryOrder),           &
 284                                  TRIM(outpatch_table(ii)%Stagger),               &!*
 285                                  outpatch_table(ii)%DimNames ,                   &!*
 286                                  outpatch_table(ii)%DomainStart,                 &
 287                                  outpatch_table(ii)%DomainEnd,                   &
 288                                  ! ARP supply magic number as MemoryStart and
 289                                  ! MemoryEnd to signal that this routine is
 290                                  ! being called from quilting.
 291                                  -998899,                                        &
 292                                  -998899,                                        &
 293                                  outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
 294                                  outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
 295                                  Status )
 296
 297                    ! Free memory associated with this patch
 298                    DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%rptr)
 299
 300                 END DO
 301
 302                 ! End of patches that not every IO Server has so can switch
 303                 ! back to collective mode.
 304                 CALL ext_pnc_end_independent_mode(DataHandle, Status)
 305
 306
 307              END IF ! Additional patches
 308
 309           ELSE IF ( outpatch_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 310
 311              ! Loop over the patches in this field up to the number that
 312              ! every IO Server has. This is slightly tricky now
 313              ! that some of them may be 'deleted.'
 314              ipatch = 0
 315              icnt = 0
 316              DO WHILE ( icnt < min_count )
 317
 318                 ipatch = ipatch + 1
 319
 320                 IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
 321
 322                 icnt = icnt + 1
 323
 324                 CALL ext_pnc_write_field ( DataHandle ,                           &
 325                                  TRIM(outpatch_table(ii)%DateStr),                &
 326                                  TRIM(outpatch_table(ii)%VarName),                &
 327                                  outpatch_table(ii)%PatchList(ipatch)%iptr,       &
 328                                  outpatch_table(ii)%FieldType,                    &!*
 329                                  local_comm, local_comm, DomainDesc,              &
 330                                  TRIM(outpatch_table(ii)%MemoryOrder),            &
 331                                  TRIM(outpatch_table(ii)%Stagger),                &!*
 332                                  outpatch_table(ii)%DimNames ,                    &!*
 333                                  outpatch_table(ii)%DomainStart,                  &
 334                                  outpatch_table(ii)%DomainEnd,                    &
 335                                  ! ARP supply magic number as MemoryStart and
 336                                  ! MemoryEnd to signal that this routine is
 337                                  ! being called from quilting.
 338                                  -998899,                                         &
 339                                  -998899,                                         &
 340                                  outpatch_table(ii)%PatchList(ipatch)%PatchStart, &
 341                                  outpatch_table(ii)%PatchList(ipatch)%PatchEnd,   &
 342                                  Status )
 343
 344                 ! Free memory associated with this patch
 345                 DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
 346
 347              END DO
 348
 349              IF( do_indep_write )THEN
 350
 351                 ! We have to do the next few patches in independent IO mode as
 352                 ! not all of the IO Servers have this many patches.
 353                 ! outpatch_table(ii)%npatch holds the no. of live patches for
 354                 ! this IO Server
 355                 CALL ext_pnc_start_independent_mode(DataHandle, Status)
 356
 357                 DO WHILE ( icnt<outpatch_table(ii)%nActivePatch )
 358
 359                    ipatch = ipatch + 1
 360
 361                    IF(outpatch_table(ii)%PatchList(ipatch)%forDeletion) CYCLE
 362
 363                    icnt = icnt + 1
 364
 365                    CALL ext_pnc_write_field ( DataHandle ,                          &
 366                                  TRIM(outpatch_table(ii)%DateStr),               &
 367                                  TRIM(outpatch_table(ii)%VarName),               &
 368                                  outpatch_table(ii)%PatchList(ipatch)%iptr,      &
 369                                  outpatch_table(ii)%FieldType,                   &!*
 370                                  local_comm, local_comm, DomainDesc ,                      &
 371                                  TRIM(outpatch_table(ii)%MemoryOrder),           &
 372                                  TRIM(outpatch_table(ii)%Stagger),               &!*
 373                                  outpatch_table(ii)%DimNames ,                   &!*
 374                                  outpatch_table(ii)%DomainStart,                 &
 375                                  outpatch_table(ii)%DomainEnd,                   &
 376                                  ! ARP supply magic number as MemoryStart and
 377                                  ! MemoryEnd to signal that this routine is
 378                                  ! being called from quilting.
 379                                  -998899,                                        &
 380                                  -998899,                                        &
 381                                  outpatch_table(ii)%PatchList(ipatch)%PatchStart,&
 382                                  outpatch_table(ii)%PatchList(ipatch)%PatchEnd,  &
 383                                  Status )
 384
 385                    ! Free memory associated with this patch
 386                    DEALLOCATE(outpatch_table(ii)%PatchList(ipatch)%iptr)
 387
 388                 END DO
 389
 390                 ! End of patches that not every IO Server has so can switch
 391                 ! back to collective mode.
 392                 CALL ext_pnc_end_independent_mode(DataHandle, Status)
 393
 394              ENDIF ! Have additional patches
 395           ENDIF
 396
 397         CASE DEFAULT
 398       END SELECT
 399
 400     ENDDO ! Loop over output buffers
 401
 402     ! Reset the table of output buffers
 403     CALL init_outbuf()
 404
 405     DEALLOCATE(count_buf)
 406
 407   END SUBROUTINE write_outbuf_pnc
 408 #endif
 409
 410   SUBROUTINE write_outbuf ( DataHandle , io_form_arg )
 411 !<DESCRIPTION>
 412 !<PRE>
 413 ! This routine writes all of the records stored in outbuf_table to the
 414 ! file referenced by DataHandle using format specified by io_form_arg.
 415 ! This routine calls the package-specific I/O routines to accomplish
 416 ! the write.
 417 ! It then re-initializes module data structures.
 418 !</PRE>
 419 !</DESCRIPTION>
 420     USE module_state_description
 421     IMPLICIT NONE
 422 #include "wrf_io_flags.h"
 423     INTEGER , INTENT(IN)  :: DataHandle, io_form_arg
 424     INTEGER               :: ii,ds1,de1,ds2,de2,ds3,de3
 425     INTEGER               :: Comm, IOComm, DomainDesc ! dummy
 426     INTEGER               :: Status
 427     CHARACTER*256         :: mess
 428     Comm = 0 ; IOComm = 0 ; DomainDesc = 0
 429
 430     DO ii = 1, num_entries
 431       WRITE(mess,*)'writing ', &
 432                     TRIM(outbuf_table(ii)%DateStr)," ",                                   &
 433                     TRIM(outbuf_table(ii)%VarName)," ",                                   &
 434                     TRIM(outbuf_table(ii)%MemoryOrder)
 435       ds1 = outbuf_table(ii)%DomainStart(1) ; de1 = outbuf_table(ii)%DomainEnd(1)
 436       ds2 = outbuf_table(ii)%DomainStart(2) ; de2 = outbuf_table(ii)%DomainEnd(2)
 437       ds3 = outbuf_table(ii)%DomainStart(3) ; de3 = outbuf_table(ii)%DomainEnd(3)
 438
 439       SELECT CASE ( io_form_arg )
 440
 441 #ifdef NETCDF
 442         CASE ( IO_NETCDF   )
 443
 444           IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 445
 446           CALL ext_ncd_write_field ( DataHandle ,                                     &
 447                                  TRIM(outbuf_table(ii)%DateStr),                      &
 448                                  TRIM(outbuf_table(ii)%VarName),                      &
 449                                  outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
 450                                  outbuf_table(ii)%FieldType,                          &  !*
 451                                  Comm, IOComm, DomainDesc ,                           &
 452                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 453                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 454                                  outbuf_table(ii)%DimNames ,                          &  !*
 455                                  outbuf_table(ii)%DomainStart,                        &
 456                                  outbuf_table(ii)%DomainEnd,                          &
 457                                  outbuf_table(ii)%DomainStart,                        &
 458                                  outbuf_table(ii)%DomainEnd,                          &
 459                                  outbuf_table(ii)%DomainStart,                        &
 460                                  outbuf_table(ii)%DomainEnd,                          &
 461                                  Status )
 462
 463           ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 464           CALL ext_ncd_write_field ( DataHandle ,                                     &
 465                                  TRIM(outbuf_table(ii)%DateStr),                      &
 466                                  TRIM(outbuf_table(ii)%VarName),                      &
 467                                  outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
 468                                  outbuf_table(ii)%FieldType,                          &  !*
 469                                  Comm, IOComm, DomainDesc ,                           &
 470                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 471                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 472                                  outbuf_table(ii)%DimNames ,                          &  !*
 473                                  outbuf_table(ii)%DomainStart,                        &
 474                                  outbuf_table(ii)%DomainEnd,                          &
 475                                  outbuf_table(ii)%DomainStart,                        &
 476                                  outbuf_table(ii)%DomainEnd,                          &
 477                                  outbuf_table(ii)%DomainStart,                        &
 478                                  outbuf_table(ii)%DomainEnd,                          &
 479                                  Status )
 480           ENDIF
 481 #endif
 482 #ifdef YYY
 483       CASE ( IO_YYY   )
 484
 485           IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 486
 487           CALL ext_yyy_write_field ( DataHandle ,                                     &
 488                                  TRIM(outbuf_table(ii)%DateStr),                      &
 489                                  TRIM(outbuf_table(ii)%VarName),                      &
 490                                  outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
 491                                  outbuf_table(ii)%FieldType,                          &  !*
 492                                  Comm, IOComm, DomainDesc ,                           &
 493                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 494                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 495                                  outbuf_table(ii)%DimNames ,                          &  !*
 496                                  outbuf_table(ii)%DomainStart,                        &
 497                                  outbuf_table(ii)%DomainEnd,                          &
 498                                  outbuf_table(ii)%DomainStart,                        &
 499                                  outbuf_table(ii)%DomainEnd,                          &
 500                                  outbuf_table(ii)%DomainStart,                        &
 501                                  outbuf_table(ii)%DomainEnd,                          &
 502                                  Status )
 503
 504           ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 505           CALL ext_yyy_write_field ( DataHandle ,                                     &
 506                                  TRIM(outbuf_table(ii)%DateStr),                      &
 507                                  TRIM(outbuf_table(ii)%VarName),                      &
 508                                  outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
 509                                  outbuf_table(ii)%FieldType,                          &  !*
 510                                  Comm, IOComm, DomainDesc ,                           &
 511                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 512                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 513                                  outbuf_table(ii)%DimNames ,                          &  !*
 514                                  outbuf_table(ii)%DomainStart,                        &
 515                                  outbuf_table(ii)%DomainEnd,                          &
 516                                  outbuf_table(ii)%DomainStart,                        &
 517                                  outbuf_table(ii)%DomainEnd,                          &
 518                                  outbuf_table(ii)%DomainStart,                        &
 519                                  outbuf_table(ii)%DomainEnd,                          &
 520                                  Status )
 521           ENDIF
 522 #endif
 523 #ifdef GRIB1
 524       CASE ( IO_GRIB1   )
 525
 526           IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 527
 528           CALL ext_gr1_write_field ( DataHandle ,                                   &
 529                                  TRIM(outbuf_table(ii)%DateStr),                      &
 530                                  TRIM(outbuf_table(ii)%VarName),                      &
 531                                  outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
 532                                  outbuf_table(ii)%FieldType,                          &  !*
 533                                  Comm, IOComm, DomainDesc ,                           &
 534                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 535                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 536                                  outbuf_table(ii)%DimNames ,                          &  !*
 537                                  outbuf_table(ii)%DomainStart,                        &
 538                                  outbuf_table(ii)%DomainEnd,                          &
 539                                  outbuf_table(ii)%DomainStart,                        &
 540                                  outbuf_table(ii)%DomainEnd,                          &
 541                                  outbuf_table(ii)%DomainStart,                        &
 542                                  outbuf_table(ii)%DomainEnd,                          &
 543                                  Status )
 544
 545           ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 546           CALL ext_gr1_write_field ( DataHandle ,                                   &
 547                                  TRIM(outbuf_table(ii)%DateStr),                      &
 548                                  TRIM(outbuf_table(ii)%VarName),                      &
 549                                  outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
 550                                  outbuf_table(ii)%FieldType,                          &  !*
 551                                  Comm, IOComm, DomainDesc ,                           &
 552                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 553                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 554                                  outbuf_table(ii)%DimNames ,                          &  !*
 555                                  outbuf_table(ii)%DomainStart,                        &
 556                                  outbuf_table(ii)%DomainEnd,                          &
 557                                  outbuf_table(ii)%DomainStart,                        &
 558                                  outbuf_table(ii)%DomainEnd,                          &
 559                                  outbuf_table(ii)%DomainStart,                        &
 560                                  outbuf_table(ii)%DomainEnd,                          &
 561                                  Status )
 562           ENDIF
 563 #endif
 564 #ifdef GRIB2
 565       CASE ( IO_GRIB2   )
 566
 567           IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 568
 569           CALL ext_gr2_write_field ( DataHandle ,                                   &
 570                                  TRIM(outbuf_table(ii)%DateStr),                      &
 571                                  TRIM(outbuf_table(ii)%VarName),                      &
 572                                  outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
 573                                  outbuf_table(ii)%FieldType,                          &  !*
 574                                  Comm, IOComm, DomainDesc ,                           &
 575                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 576                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 577                                  outbuf_table(ii)%DimNames ,                          &  !*
 578                                  outbuf_table(ii)%DomainStart,                        &
 579                                  outbuf_table(ii)%DomainEnd,                          &
 580                                  outbuf_table(ii)%DomainStart,                        &
 581                                  outbuf_table(ii)%DomainEnd,                          &
 582                                  outbuf_table(ii)%DomainStart,                        &
 583                                  outbuf_table(ii)%DomainEnd,                          &
 584                                  Status )
 585
 586           ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 587           CALL ext_gr2_write_field ( DataHandle ,                                   &
 588                                  TRIM(outbuf_table(ii)%DateStr),                      &
 589                                  TRIM(outbuf_table(ii)%VarName),                      &
 590                                  outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
 591                                  outbuf_table(ii)%FieldType,                          &  !*
 592                                  Comm, IOComm, DomainDesc ,                           &
 593                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 594                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 595                                  outbuf_table(ii)%DimNames ,                          &  !*
 596                                  outbuf_table(ii)%DomainStart,                        &
 597                                  outbuf_table(ii)%DomainEnd,                          &
 598                                  outbuf_table(ii)%DomainStart,                        &
 599                                  outbuf_table(ii)%DomainEnd,                          &
 600                                  outbuf_table(ii)%DomainStart,                        &
 601                                  outbuf_table(ii)%DomainEnd,                          &
 602                                  Status )
 603           ENDIF
 604 #endif
 605 #ifdef INTIO
 606         CASE ( IO_INTIO  )
 607           IF ( outbuf_table(ii)%FieldType .EQ. WRF_FLOAT ) THEN
 608
 609           CALL ext_int_write_field ( DataHandle ,                                     &
 610                                  TRIM(outbuf_table(ii)%DateStr),                      &
 611                                  TRIM(outbuf_table(ii)%VarName),                      &
 612                                  outbuf_table(ii)%rptr(ds1:de1,ds2:de2,ds3:de3),      &
 613                                  outbuf_table(ii)%FieldType,                          &  !*
 614                                  Comm, IOComm, DomainDesc ,                           &
 615                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 616                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 617                                  outbuf_table(ii)%DimNames ,                          &  !*
 618                                  outbuf_table(ii)%DomainStart,                        &
 619                                  outbuf_table(ii)%DomainEnd,                          &
 620                                  outbuf_table(ii)%DomainStart,                        &
 621                                  outbuf_table(ii)%DomainEnd,                          &
 622                                  outbuf_table(ii)%DomainStart,                        &
 623                                  outbuf_table(ii)%DomainEnd,                          &
 624                                  Status )
 625
 626           ELSE IF ( outbuf_table(ii)%FieldType .EQ. WRF_INTEGER ) THEN
 627
 628           CALL ext_int_write_field ( DataHandle ,                                     &
 629                                  TRIM(outbuf_table(ii)%DateStr),                      &
 630                                  TRIM(outbuf_table(ii)%VarName),                      &
 631                                  outbuf_table(ii)%iptr(ds1:de1,ds2:de2,ds3:de3),      &
 632                                  outbuf_table(ii)%FieldType,                          &  !*
 633                                  Comm, IOComm, DomainDesc ,                           &
 634                                  TRIM(outbuf_table(ii)%MemoryOrder),                  &
 635                                  TRIM(outbuf_table(ii)%Stagger),                      &  !*
 636                                  outbuf_table(ii)%DimNames ,                          &  !*
 637                                  outbuf_table(ii)%DomainStart,                        &
 638                                  outbuf_table(ii)%DomainEnd,                          &
 639                                  outbuf_table(ii)%DomainStart,                        &
 640                                  outbuf_table(ii)%DomainEnd,                          &
 641                                  outbuf_table(ii)%DomainStart,                        &
 642                                  outbuf_table(ii)%DomainEnd,                          &
 643                                  Status )
 644
 645           ENDIF
 646 #endif
 647         CASE DEFAULT
 648       END SELECT
 649
 650
 651       IF ( ASSOCIATED( outbuf_table(ii)%rptr) ) DEALLOCATE(outbuf_table(ii)%rptr)
 652       IF ( ASSOCIATED( outbuf_table(ii)%iptr) ) DEALLOCATE(outbuf_table(ii)%iptr)
 653       NULLIFY( outbuf_table(ii)%rptr )
 654       NULLIFY( outbuf_table(ii)%iptr )
 655     ENDDO
 656     CALL init_outbuf
 657   END SUBROUTINE write_outbuf
 658
 659
 660   SUBROUTINE stitch_outbuf_patches(ibuf)
 661     USE module_timing
 662     IMPLICIT none
 663     INTEGER, INTENT(in) :: ibuf
 664 !<DESCRIPTION>
 665 !<PRE>
 666 ! This routine does the "output quilting" for the case where quilting has been
 667 ! built to use Parallel NetCDF. Unlike store_patch_in_outbuf() we do not have
 668 ! data for the whole domain --- instead we aim to quilt as much of the data as
 669 ! possible in order to reduce the number of separate writes that we must do.
 670 !</PRE>
 671 !</DESCRIPTION>
 672 #include "wrf_io_flags.h"
 673     INTEGER                              :: ipatch, jpatch, ii
 674     INTEGER                              :: ierr
 675     INTEGER                              :: npatches
 676     INTEGER,              DIMENSION(3)   :: newExtent, pos
 677     INTEGER, ALLOCATABLE, DIMENSION(:,:) :: OldPatchStart
 678     INTEGER, POINTER,   DIMENSION(:,:,:) :: ibuffer
 679     REAL,    POINTER,   DIMENSION(:,:,:) :: rbuffer
 680     CHARACTER*256                        :: mess
 681 integer i,j
 682
 683 !    CALL start_timing()
 684
 685     IF(LEN_TRIM(outpatch_table(ibuf)%MemoryOrder) < 2)THEN
 686        ! This field is a scalar or 1D array. Such quantities are replicated
 687        ! across compute nodes and therefore we need only keep a single
 688        ! patch - delete all but the first in the list
 689       IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
 690
 691           DO jpatch=2,outpatch_table(ibuf)%npatch,1
 692              outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
 693              outpatch_table(ibuf)%nActivePatch = &
 694                                  outpatch_table(ibuf)%nActivePatch - 1
 695              DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%rptr)
 696           END DO
 697
 698       ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
 699
 700           DO jpatch=2,outpatch_table(ibuf)%npatch,1
 701              outpatch_table(ibuf)%PatchList(jpatch)%forDeletion = .TRUE.
 702              outpatch_table(ibuf)%nActivePatch = &
 703                                  outpatch_table(ibuf)%nActivePatch - 1
 704              DEALLOCATE(outpatch_table(ibuf)%PatchList(jpatch)%iptr)
 705           END DO
 706
 707       ELSE
 708          CALL wrf_error_fatal("stitch_outbuf_patches: unrecognised Field Type")
 709       END IF
 710
 711 !     CALL end_timing("stitch_outbuf_patches: deleting replicated patches")
 712
 713       RETURN
 714
 715     END IF ! Field is scalar or 1D
 716
 717     ! Otherwise, this field _is_ distributed across compute PEs and therefore
 718     ! it's worth trying to stitch patches together...
 719     ALLOCATE(OldPatchStart(3,outpatch_table(ibuf)%npatch), &
 720              JoinedPatches(outpatch_table(ibuf)%npatch,    &
 721                            outpatch_table(ibuf)%npatch),   &
 722              PatchCount(outpatch_table(ibuf)%npatch),      &
 723              Stat=ierr)
 724     IF(ierr /= 0)THEN
 725        CALL wrf_message('stitch_outbuf_patches: unable to stitch patches as allocate failed.')
 726        RETURN
 727     END IF
 728
 729     JoinedPatches(:,:) = -1
 730     ! Initialise these arrays to catch failures in the above allocate on
 731     ! linux-based systems (e.g. Cray XE) where allocation only actually
 732     ! performed when requested memory is touched.
 733     PatchCount(:) = 0
 734     OldPatchStart(:,:) = 0
 735
 736     NULLIFY(ibuffer)
 737     NULLIFY(rbuffer)
 738
 739     DO jpatch=1,outpatch_table(ibuf)%npatch,1
 740
 741        ! Each patch consists of just itself initially
 742        JoinedPatches(1,jpatch) = jpatch
 743        PatchCount(jpatch) = 1
 744
 745        ! Store the location of each patch for use after we've decided how to
 746        ! stitch them together
 747        OldPatchStart(:,jpatch) = outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:)
 748     END DO
 749
 750     ! Search through patches to find pairs that we can stitch together
 751     ipatch = 1
 752     OUTER: DO WHILE(ipatch < outpatch_table(ibuf)%npatch)
 753
 754        IF( outpatch_table(ibuf)%PatchList(ipatch)%forDeletion )THEN
 755           ipatch = ipatch + 1
 756           CYCLE OUTER
 757        END IF
 758
 759        INNER: DO jpatch=ipatch+1,outpatch_table(ibuf)%npatch,1
 760
 761           IF(outpatch_table(ibuf)%PatchList(jpatch)%forDeletion )THEN
 762              CYCLE INNER
 763           END IF
 764
 765           ! Look for patches that can be concatenated with ipatch in the first
 766           ! dimension (preferred since that is contiguous in memory in F90)
 767           !  ________________         ____________
 768           !  |               |        |           |
 769           ! Startx(j)     Endx(j) Startx(i)   Endx(i)
 770           !
 771           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1) == &
 772               (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) - 1) )THEN
 773
 774              ! Patches contiguous in first dimension - do they have the same
 775              ! extents in the other two dimensions?
 776              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
 777                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
 778                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
 779                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
 780                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
 781                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
 782                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
 783                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
 784
 785                 ! We can concatenate these two patches in first dimension
 786 !                WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
 787 !                CALL wrf_message(mess)
 788
 789                 ! Grow patch ipatch to include jpatch
 790                 outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) = &
 791                          outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)
 792                 CALL merge_patches(ibuf, ipatch, jpatch)
 793
 794                 ! Go again...
 795                 ipatch = 1
 796                 CYCLE OUTER
 797              END IF
 798           END IF
 799           !  ______________         ____________
 800           !  |             |        |           |
 801           ! Startx(i)    Endx(i) Startx(j)   Endx(j)
 802           !
 803           IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1) == &
 804              (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) + 1))THEN
 805
 806              ! Patches contiguous in first dimension - do they have the same
 807              ! extents in the other two dimensions?
 808              IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
 809                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
 810                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
 811                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)   ) .AND.&
 812                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
 813                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
 814                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
 815                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
 816
 817                  ! We can concatenate these two patches in first dimension
 818 !                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 1')") ipatch, jpatch
 819 !                 CALL wrf_message(mess)
 820
 821                 ! Grow patch ipatch to include jpatch
 822                 outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1) = &
 823                         outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)
 824                 CALL merge_patches(ibuf, ipatch, jpatch)
 825
 826                 ! Go again...
 827                 ipatch = 1
 828                 CYCLE OUTER
 829               END IF
 830            END IF
 831
 832            ! Try the second dimension
 833            IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2) == &
 834                 (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) - 1))THEN
 835
 836               ! Patches contiguous in second dimension - do they have the same
 837               ! extents in the other two dimensions?
 838               IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
 839                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
 840                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
 841                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
 842                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
 843                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
 844                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
 845                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
 846
 847                  ! We can concatenate these two patches in second dimension
 848 !                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
 849 !                 CALL wrf_message(mess)
 850
 851                  ! Grow patch ipatch to include jpatch
 852                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) = &
 853                          outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)
 854                  CALL merge_patches(ibuf, ipatch, jpatch)
 855
 856                  ! Go again...
 857                  ipatch = 1
 858                  CYCLE OUTER
 859               END IF
 860            END IF
 861
 862            IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2) == &
 863                 (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) + 1) )THEN
 864
 865               ! Patches contiguous in second dimension - do they have the same
 866               ! extents in the other two dimensions?
 867               IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
 868                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
 869                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
 870                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
 871                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)==      &
 872                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) ) .AND.&
 873                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)  ==      &
 874                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3)) )THEN
 875
 876                  ! We can concatenate these two patches in second dimension
 877 !                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 2')") ipatch, jpatch
 878 !                 CALL wrf_message(mess)
 879
 880                  ! Grow patch ipatch to include jpatch
 881                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2) = &
 882                          outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)
 883                  CALL merge_patches(ibuf, ipatch, jpatch)
 884
 885                  ! Go again...
 886                  ipatch = 1
 887                  CYCLE OUTER
 888               END IF
 889            END IF
 890
 891            ! Try the third dimension
 892            IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3) == &
 893                (outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) - 1) )THEN
 894
 895               ! Patches contiguous in second dimension - do they have the same
 896               ! extents in the other two dimensions?
 897               IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
 898                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
 899                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
 900                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
 901                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
 902                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
 903                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
 904                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
 905
 906                  ! We can concatenate these two patches in the third dimension
 907 !                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
 908 !                 CALL wrf_message(mess)
 909
 910                  ! Grow patch ipatch to include jpatch
 911                  outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(3) = &
 912                          outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3)
 913                  CALL merge_patches(ibuf, ipatch, jpatch)
 914
 915                  ! Go again...
 916                  ipatch = 1
 917                  CYCLE OUTER
 918               END IF
 919            END IF
 920
 921            IF(outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3) == &
 922                 (outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) + 1))THEN
 923
 924               ! Patches contiguous in second dimension - do they have the same
 925               ! extents in the other two dimensions?
 926               IF( (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1)==     &
 927                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(1) ) .AND.&
 928                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1)  ==      &
 929                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(1)   ) .AND.&
 930                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2)==      &
 931                   outpatch_table(ibuf)%PatchList(ipatch)%PatchStart(2) ) .AND.&
 932                  (outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2)  ==      &
 933                   outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(2)) )THEN
 934
 935                  ! We can concatenate these two patches in the third dimension
 936 !                 WRITE(mess,"('Can concatenate patches ',I3,' and ',I3,' in dim 3')") ipatch, jpatch
 937 !                 CALL wrf_message(mess)
 938
 939                  ! Grow patch ipatch to include jpatch
 940                  outpatch_table(ibuf)%PatchList(ipatch)%PatchEnd(3) = &
 941                          outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
 942                  CALL merge_patches(ibuf, ipatch, jpatch)
 943
 944                  ! Go again...
 945                  ipatch = 1
 946                  CYCLE OUTER
 947               END IF
 948            END IF
 949
 950        END DO INNER
 951
 952        ipatch = ipatch + 1
 953
 954     END DO OUTER
 955
 956     npatches = 0
 957
 958     DO jpatch=1,outpatch_table(ibuf)%npatch,1
 959
 960        IF ( outpatch_table(ibuf)%PatchList(jpatch)%forDeletion ) CYCLE
 961
 962 !       WRITE(mess,"('Patch ',I3,': [',I3,': ',I3,'],[',I3,':',I3,'],[',I3,':',I3,']')") jpatch, outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(1), &
 963 !             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(1),   &
 964 !             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(2), &
 965 !             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(2),   &
 966 !             outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(3), &
 967 !             outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(3)
 968 !       CALL wrf_message(mess)
 969
 970        ! Count how many patches we're left with
 971        npatches = npatches + 1
 972
 973        ! If no patches have been merged together to make this patch then we
 974        ! don't have to do any more with it
 975        IF(PatchCount(jpatch) == 1) CYCLE
 976
 977        ! Get the extent of this patch
 978        newExtent(:) = outpatch_table(ibuf)%PatchList(jpatch)%PatchEnd(:) - &
 979                       outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
 980        ! Allocate a buffer to hold all of its data
 981        IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_FLOAT ) THEN
 982           ALLOCATE(rbuffer(newExtent(1), newExtent(2), newExtent(3)), &
 983                    Stat=ierr)
 984        ELSE IF ( outpatch_table(ibuf)%FieldType .EQ. WRF_INTEGER ) THEN
 985           ALLOCATE(ibuffer(newExtent(1), newExtent(2), newExtent(3)), &
 986                    Stat=ierr)
 987        END IF
 988        IF(ierr /= 0)THEN
 989           CALL wrf_error_fatal('stitch_outbuf_patches: unable to stitch patches as allocate for merge buffer failed.')
 990           RETURN
 991        END IF
 992
 993        ! Copy data into this buffer from each of the patches that are being
 994        ! stitched together
 995        IF( ASSOCIATED(rbuffer) )THEN
 996
 997 !         CALL start_timing()
 998
 999           DO ipatch=1,PatchCount(jpatch),1
1000
1001              ii = JoinedPatches(ipatch, jpatch)
1002
1003              ! Work out where to put it - the PatchList(i)%PatchStart() has been
1004              ! updated to hold the start of the newly quilted patch i. It will
1005              ! therefore be less than or equal to the starts of each of the
1006              ! constituent patches.
1007              pos(:) = OldPatchStart(:,ii) - &
1008                       outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
1009              ! Do the copy - can use the PatchExtent data here because that
1010              ! wasn't modified during the stitching of the patches.
1011
1012              rbuffer(pos(1): pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
1013                      pos(2): pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
1014                      pos(3): pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) &
1015                              = &
1016                       outpatch_table(ibuf)%PatchList(ii)%rptr(:, :, :)
1017
1018              ! Having copied the data from this patch, we can free-up the
1019              ! associated buffer
1020              DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%rptr)
1021           END DO
1022
1023 !         CALL end_timing("Data copy into new real patch")
1024
1025           ! Re-assign the pointer associated with this patch to the new,
1026           ! larger, buffer containing the quilted patches
1027           outpatch_table(ibuf)%PatchList(jpatch)%rptr => rbuffer
1028
1029           ! Unset the original pointer to this buffer
1030           NULLIFY(rbuffer)
1031
1032        ELSE IF( ASSOCIATED(ibuffer) )THEN
1033
1034 !         CALL start_timing()
1035
1036           DO ipatch=1,PatchCount(jpatch),1
1037
1038              ii = JoinedPatches(ipatch, jpatch)
1039
1040              ! Work out where to put it
1041              pos(:) = OldPatchStart(:,ii) - &
1042                       outpatch_table(ibuf)%PatchList(jpatch)%PatchStart(:) + 1
1043              ! Do the copy - can use the PatchExtent data here because that
1044              ! wasn't modified during the stitching of the patches.
1045              ibuffer(pos(1): &
1046                  pos(1)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(1)-1, &
1047                  pos(2): &
1048                  pos(2)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(2)-1, &
1049                  pos(3): &
1050                  pos(3)+outpatch_table(ibuf)%PatchList(ii)%PatchExtent(3)-1 ) = &
1051                       outpatch_table(ibuf)%PatchList(ii)%iptr(:, :, :)
1052
1053              DEALLOCATE(outpatch_table(ibuf)%PatchList(ii)%iptr)
1054           END DO
1055
1056 !         CALL end_timing("Data copy into new integer patch")
1057
1058           ! Re-assign the pointer associated with this patch to the new,
1059           ! larger, buffer containing the quilted patches
1060           outpatch_table(ibuf)%PatchList(jpatch)%iptr => ibuffer
1061           NULLIFY(ibuffer)
1062
1063        END IF
1064
1065     END DO
1066
1067     WRITE(mess,*) "--------------------------"
1068     CALL wrf_message(mess)
1069
1070     ! Record how many patches we're left with
1071     outpatch_table(ibuf)%nPatch = npatches
1072
1073     DEALLOCATE(OldPatchStart, JoinedPatches, PatchCount)
1074
1075 !   CALL end_timing("stitch patches")
1076
1077   END SUBROUTINE stitch_outbuf_patches
1078
1079   !-------------------------------------------------------------------------
1080   SUBROUTINE merge_patches(itab, ipatch, jpatch)
1081     INTEGER, INTENT(in) :: itab, ipatch, jpatch
1082     ! Merge patch jpatch into patch ipatch and then 'delete' jpatch
1083     INTEGER :: ii
1084
1085     ! Keep track of which patches we've merged: ipatch takes
1086     ! on all of the original patches which currently make up
1087     ! jpatch.
1088     DO ii=1,PatchCount(jpatch),1
1089        PatchCount(ipatch) = PatchCount(ipatch) + 1
1090        JoinedPatches(PatchCount(ipatch),ipatch) = JoinedPatches(ii,jpatch)
1091     END DO
1092     ! and mark patch jpatch for deletion
1093     outpatch_table(itab)%PatchList(jpatch)%forDeletion = .TRUE.
1094     ! decrement the count of active patches
1095     outpatch_table(itab)%nActivePatch = outpatch_table(itab)%nActivePatch - 1
1096
1097   END SUBROUTINE merge_patches
1098
1099 END MODULE module_quilt_outbuf_ops
1100
1101 ! don't let other programs see the definition of this; type mismatches
1102 ! on inbuf will result;  may want to make a module program at some point
1103   SUBROUTINE store_patch_in_outbuf( inbuf_r, inbuf_i, DateStr, VarName , FieldType, MemoryOrder, Stagger, DimNames, &
1104                                     DomainStart , DomainEnd , &
1105                                     MemoryStart , MemoryEnd , &
1106                                     PatchStart , PatchEnd )
1107 !<DESCRIPTION>
1108 !<PRE>
1109 ! This routine does the "output quilting".
1110 !
1111 ! It stores a patch in the appropriate location in a domain-sized array
1112 ! within an element of the outbuf_table data structure.  DateStr, VarName, and
1113 ! MemoryOrder are used to uniquely identify which element of outbuf_table is
1114 ! associated with this array.  If no element is associated, then this routine
1115 ! first assigns an unused element and allocates space within that element for
1116 ! the globally-sized array.  This routine also stores DateStr, VarName,
1117 ! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within
1118 ! the same element of outbuf.
1119 !</PRE>
1120 !</DESCRIPTION>
1121     USE module_quilt_outbuf_ops
1122     IMPLICIT NONE
1123 #include "wrf_io_flags.h"
1124     INTEGER ,                INTENT(IN) :: FieldType
1125     REAL    , DIMENSION(*) , INTENT(IN) :: inbuf_r
1126     INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf_i
1127     INTEGER , DIMENSION(3) , INTENT(IN) :: DomainStart , DomainEnd , MemoryStart , MemoryEnd , PatchStart , PatchEnd
1128     CHARACTER*(*)          , INTENT(IN) :: DateStr , VarName, MemoryOrder , Stagger, DimNames(3)
1129 ! Local
1130     CHARACTER*256         ::  mess
1131     INTEGER               :: l,m,n,ii,jj
1132     LOGICAL               :: found
1133
1134     ! Find the VarName if it's in the buffer already
1135     ii = 1
1136     found = .false.
1137     DO WHILE ( .NOT. found .AND. ii .LE. num_entries )
1138       !TBH:  need to test other attributes too!
1139       IF ( TRIM(VarName) .EQ. TRIM(outbuf_table(ii)%VarName) ) THEN
1140         IF ( TRIM(DateStr) .EQ. TRIM(outbuf_table(ii)%DateStr) ) THEN
1141           IF ( TRIM(MemoryOrder) .EQ. TRIM(outbuf_table(ii)%MemoryOrder) ) THEN
1142             found = .true.
1143           ELSE
1144             CALL wrf_error_fatal("store_patch_in_outbuf: memory order disagreement")
1145           ENDIF
1146         ELSE
1147           CALL wrf_error_fatal("store_patch_in_outbuf: multiple dates in buffer")
1148         ENDIF
1149       ELSE
1150         ii = ii + 1
1151       ENDIF
1152     ENDDO
1153     IF ( .NOT. found ) THEN
1154       num_entries = num_entries + 1
1155       IF      ( FieldType .EQ. WRF_FLOAT ) THEN
1156         ALLOCATE( outbuf_table(num_entries)%rptr(DomainStart(1):DomainEnd(1), &
1157                                                  DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
1158       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1159         ALLOCATE( outbuf_table(num_entries)%iptr(DomainStart(1):DomainEnd(1), &
1160                                                  DomainStart(2):DomainEnd(2),DomainStart(3):DomainEnd(3)) )
1161       ELSE
1162         write(mess,*)"store_patch_in_outbuf: unsupported type ", FieldType
1163         CALL wrf_error_fatal(mess)
1164       ENDIF
1165       outbuf_table(num_entries)%VarName = TRIM(VarName)
1166       outbuf_table(num_entries)%DateStr = TRIM(DateStr)
1167       outbuf_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
1168       outbuf_table(num_entries)%Stagger = TRIM(Stagger)
1169       outbuf_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
1170       outbuf_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
1171       outbuf_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
1172       outbuf_table(num_entries)%DomainStart = DomainStart
1173       outbuf_table(num_entries)%DomainEnd = DomainEnd
1174       outbuf_table(num_entries)%FieldType = FieldType
1175       ii = num_entries
1176     ENDIF
1177     jj = 1
1178     IF (  FieldType .EQ. WRF_FLOAT ) THEN
1179       DO n = PatchStart(3),PatchEnd(3)
1180         DO m = PatchStart(2),PatchEnd(2)
1181           DO l = PatchStart(1),PatchEnd(1)
1182             outbuf_table(ii)%rptr(l,m,n) = inbuf_r(jj)
1183             jj = jj + 1
1184           ENDDO
1185         ENDDO
1186       ENDDO
1187     ENDIF
1188     IF (  FieldType .EQ. WRF_INTEGER ) THEN
1189       DO n = PatchStart(3),PatchEnd(3)
1190         DO m = PatchStart(2),PatchEnd(2)
1191           DO l = PatchStart(1),PatchEnd(1)
1192             outbuf_table(ii)%iptr(l,m,n) = inbuf_i(jj)
1193             jj = jj + 1
1194           ENDDO
1195         ENDDO
1196       ENDDO
1197     ENDIF
1198
1199     RETURN
1200
1201   END SUBROUTINE store_patch_in_outbuf
1202
1203 ! don't let other programs see the definition of this; type mismatches
1204 ! on inbuf will result;  may want to make a module program at some point
1205   SUBROUTINE store_patch_in_outbuf_pnc( inbuf_r, inbuf_i, DateStr, VarName , &
1206                                         FieldType, MemoryOrder, Stagger,     &
1207                                         DimNames ,                &
1208                                         DomainStart , DomainEnd , &
1209                                         MemoryStart , MemoryEnd , &
1210                                         PatchStart  , PatchEnd  , &
1211                                         ntasks )
1212 !<DESCRIPTION>
1213 !<PRE>
1214 ! This routine stores a patch in an array within an element of the
1215 ! outpatch_table%PatchList data structure.  DateStr, VarName, and
1216 ! MemoryOrder are used to uniquely identify which element of outpatch_table is
1217 ! associated with this array.  If no element is associated, then this routine
1218 ! first assigns an unused element and allocates space within that element.
1219 ! This routine also stores DateStr, VarName,
1220 ! FieldType, MemoryOrder, Stagger, DimNames, DomainStart, and DomainEnd within
1221 ! the same element of outpatch.
1222 !</PRE>
1223 !</DESCRIPTION>
1224     USE module_quilt_outbuf_ops, Only: outpatch_table, tabsize, num_entries
1225     USE module_timing
1226     IMPLICIT NONE
1227 #include "wrf_io_flags.h"
1228     INTEGER ,               INTENT(IN) :: FieldType
1229     REAL    , DIMENSION(*), INTENT(IN) :: inbuf_r
1230     INTEGER , DIMENSION(*), INTENT(IN) :: inbuf_i
1231     INTEGER , DIMENSION(3), INTENT(IN) :: DomainStart, DomainEnd, MemoryStart,&
1232                                           MemoryEnd , PatchStart , PatchEnd
1233     CHARACTER*(*)         , INTENT(IN) :: DateStr , VarName, MemoryOrder , &
1234                                           Stagger, DimNames(3)
1235     INTEGER, INTENT(IN) :: ntasks ! Number of compute tasks associated with
1236                                   ! this IO server
1237 ! Local
1238     CHARACTER*256         :: mess
1239     INTEGER               :: l,m,n,ii,jj,ipatch,ierr
1240     LOGICAL               :: found
1241
1242 !   CALL start_timing()
1243
1244     ! Find the VarName if it's in the buffer already
1245     ii = 1
1246     found = .false.
1247     DO WHILE ( .NOT. found .AND. ii .LE. num_entries )
1248       !TBH:  need to test other attributes too!
1249       IF ( TRIM(VarName) .EQ. TRIM(outpatch_table(ii)%VarName) ) THEN
1250         IF ( TRIM(DateStr) .EQ. TRIM(outpatch_table(ii)%DateStr) ) THEN
1251           IF ( TRIM(MemoryOrder) .EQ. TRIM(outpatch_table(ii)%MemoryOrder) ) THEN
1252             found = .true.
1253           ELSE
1254             CALL wrf_error_fatal("store_patch_in_outbuf_pnc: memory order disagreement")
1255           ENDIF
1256         ELSE
1257           CALL wrf_error_fatal("store_patch_in_outbuf_pnc: multiple dates in buffer")
1258         ENDIF
1259       ELSE
1260         ii = ii + 1
1261       ENDIF
1262     ENDDO
1263     IF ( .NOT. found ) THEN
1264       num_entries = num_entries + 1
1265       IF(num_entries > tabsize)THEN
1266          WRITE(mess,*) 'Number of entries in outpatch_table has exceeded tabsize (',tabsize,') in module_quilt_outbuf_ops::store_patch_in_outbuf_pnc'
1267          CALL wrf_error_fatal(mess)
1268       END IF
1269       outpatch_table(num_entries)%npatch = 0
1270
1271       outpatch_table(num_entries)%VarName     = TRIM(VarName)
1272       outpatch_table(num_entries)%DateStr     = TRIM(DateStr)
1273       outpatch_table(num_entries)%MemoryOrder = TRIM(MemoryOrder)
1274       outpatch_table(num_entries)%Stagger     = TRIM(Stagger)
1275       outpatch_table(num_entries)%DimNames(1) = TRIM(DimNames(1))
1276       outpatch_table(num_entries)%DimNames(2) = TRIM(DimNames(2))
1277       outpatch_table(num_entries)%DimNames(3) = TRIM(DimNames(3))
1278       outpatch_table(num_entries)%DomainStart = DomainStart
1279       outpatch_table(num_entries)%DomainEnd   = DomainEnd
1280       outpatch_table(num_entries)%FieldType   = FieldType
1281       ! Allocate the table for the list of patches for this output - it
1282       ! will have as many entries as there are compute tasks associated with
1283       ! this IO server.
1284       IF ( ALLOCATED(outpatch_table(num_entries)%PatchList) ) &
1285          DEALLOCATE(outpatch_table(num_entries)%PatchList)
1286       ALLOCATE(outpatch_table(num_entries)%PatchList(ntasks), Stat=ierr)
1287       IF(ierr /= 0)THEN
1288          WRITE(mess,*)'num_entries ',num_entries,' ntasks ',ntasks,' ierr ',ierr
1289          CALL wrf_message(mess)
1290          WRITE(mess,*)'Allocation for ',ntasks, &
1291                       ' patches in store_patch_in_outbuf_pnc() failed.'
1292          CALL wrf_error_fatal( mess )
1293       ENDIF
1294       ! Initialise the list of patches
1295       DO ii=1, ntasks, 1
1296          outpatch_table(num_entries)%PatchList(ii)%forDeletion = .FALSE.
1297          NULLIFY(outpatch_table(num_entries)%PatchList(ii)%rptr)
1298          NULLIFY(outpatch_table(num_entries)%PatchList(ii)%iptr)
1299          outpatch_table(num_entries)%PatchList(ii)%PatchStart(:) = 0
1300          outpatch_table(num_entries)%PatchList(ii)%PatchEnd(:) = 0
1301          outpatch_table(num_entries)%PatchList(ii)%PatchExtent(:) = 0
1302       END DO
1303
1304       ii = num_entries
1305
1306       WRITE(mess,*)'Adding field entry no. ',num_entries
1307       CALL wrf_message(mess)
1308       WRITE(mess,*)'Variable = ',TRIM(VarName)
1309       CALL wrf_message(mess)
1310       WRITE(mess,*)'Domain start = ',DomainStart(:)
1311       CALL wrf_message(mess)
1312       WRITE(mess,*)'Domain end   = ',DomainEnd(:)
1313       CALL wrf_message(mess)
1314     ENDIF
1315
1316     ! We only store > 1 patch if the field has two or more dimensions. Scalars
1317     ! and 1D arrays are replicated across compute nodes and therefore we only
1318     ! need keep a single patch.
1319     IF(LEN_TRIM(outpatch_table(ii)%MemoryOrder) >= 2 .OR. &
1320        outpatch_table(ii)%npatch < 1)THEN
1321
1322        ! Add another patch
1323        outpatch_table(ii)%npatch = outpatch_table(ii)%npatch + 1
1324        outpatch_table(ii)%nActivePatch = outpatch_table(ii)%npatch
1325
1326        ipatch = outpatch_table(ii)%npatch
1327
1328        outpatch_table(ii)%PatchList(ipatch)%PatchStart(:) = PatchStart(:)
1329        outpatch_table(ii)%PatchList(ipatch)%PatchEnd(:)   = PatchEnd(:)
1330        outpatch_table(ii)%PatchList(ipatch)%PatchExtent(:)= PatchEnd(:) - PatchStart(:) + 1
1331
1332        ierr = 0
1333
1334        IF      ( FieldType .EQ. WRF_FLOAT ) THEN
1335           ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%rptr( &
1336                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
1337                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
1338                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
1339                                                  Stat=ierr)
1340        ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
1341           ALLOCATE( outpatch_table(ii)%PatchList(ipatch)%iptr( &
1342                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1), &
1343                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2), &
1344                                                  outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3)),&
1345                                                  Stat=ierr)
1346        ELSE
1347           WRITE(mess,*)"store_patch_in_outbuf_pnc: unsupported type ", FieldType
1348           CALL wrf_error_fatal(mess)
1349        ENDIF
1350
1351        IF(ierr /= 0)THEN
1352           WRITE(mess,*)"store_patch_in_outbuf_pnc: failed to allocate memory to hold patch for var. ", TRIM(VarName)
1353           CALL wrf_error_fatal(mess)
1354        END IF
1355
1356        jj = 1
1357
1358        WRITE(mess,"('Variable ',(A),', patch ',I3,': (',I3,':',I3,',',I3,':',I3,',',I3,':',I3,')')")&
1359                 TRIM(outpatch_table(ii)%VarName),  &
1360                 ipatch, &
1361                 PatchStart(1),PatchEnd(1), &
1362                 PatchStart(2),PatchEnd(2), &
1363                 PatchStart(3),PatchEnd(3)
1364        CALL wrf_message(mess)
1365
1366        IF (  FieldType .EQ. WRF_FLOAT ) THEN
1367           DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
1368              DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
1369                 DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
1370                    outpatch_table(ii)%PatchList(ipatch)%rptr(l,m,n) = inbuf_r(jj)
1371                    jj = jj + 1
1372                 ENDDO
1373              ENDDO
1374           ENDDO
1375        ENDIF
1376        IF (  FieldType .EQ. WRF_INTEGER ) THEN
1377           DO n = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(3),1
1378              DO m = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(2),1
1379                 DO l = 1,outpatch_table(ii)%PatchList(ipatch)%PatchExtent(1),1
1380                    outpatch_table(ii)%PatchList(ipatch)%iptr(l,m,n) = inbuf_i(jj)
1381                    jj = jj + 1
1382                 ENDDO
1383              ENDDO
1384           ENDDO
1385        ENDIF
1386
1387     END IF ! We need to add another patch
1388
1389 !   CALL end_timing("store patch in outbuf")
1390
1391     RETURN
1392
1393   END SUBROUTINE store_patch_in_outbuf_pnc
1394
1395 !call add_to_bufsize_for_field( VarName, hdrbufsize+chunksize )
1396
1397   SUBROUTINE add_to_bufsize_for_field( VarName, Nbytes )
1398 !<DESCRIPTION>
1399 !<PRE>
1400 ! This routine is a wrapper for C routine add_to_bufsize_for_field_c() that
1401 ! is used to accumulate buffer sizes.  Buffer size Nbytes is added to the
1402 ! curent buffer size for the buffer named VarName.  Any buffer space
1403 ! associated with VarName is freed.  If a buffer named VarName does not exist,
1404 ! a new one is assigned and its size is set to Nbytes.
1405 !</PRE>
1406 !</DESCRIPTION>
1407     USE module_quilt_outbuf_ops
1408     IMPLICIT NONE
1409     CHARACTER*(*)    , INTENT(IN) :: VarName
1410     INTEGER          , INTENT(IN) :: Nbytes
1411 ! Local
1412     CHARACTER*256         :: mess
1413     INTEGER               :: i, ierr
1414     INTEGER               :: VarNameAsInts( 256 )
1415     VarNameAsInts( 1 ) = len(trim(VarName))
1416     DO i = 2, len(trim(VarName)) + 1
1417       VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
1418     ENDDO
1419     CALL add_to_bufsize_for_field_c ( VarNameAsInts, Nbytes )
1420     RETURN
1421   END SUBROUTINE add_to_bufsize_for_field
1422
1423   SUBROUTINE store_piece_of_field( inbuf, VarName, Nbytes )
1424 !<DESCRIPTION>
1425 !<PRE>
1426 ! This routine is a wrapper for C routine store_piece_of_field_c() that
1427 ! is used to store pieces of a field in an internal buffer.  Nbytes bytes of
1428 ! buffer inbuf are appended to the end of the internal buffer named VarName.
1429 ! An error occurs if either an internal buffer named VarName does not exist or
1430 ! if there are fewer than Nbytes bytes left in the internal buffer.
1431 !</PRE>
1432 !</DESCRIPTION>
1433     USE module_quilt_outbuf_ops
1434     IMPLICIT NONE
1435     INTEGER ,                INTENT(IN) :: Nbytes
1436     INTEGER , DIMENSION(*) , INTENT(IN) :: inbuf
1437     CHARACTER*(*)          , INTENT(IN) :: VarName
1438 ! Local
1439     CHARACTER*256         :: mess
1440     INTEGER               :: i, ierr
1441     INTEGER               :: VarNameAsInts( 256 )
1442
1443     VarNameAsInts( 1 ) = len(trim(VarName))
1444     DO i = 2, len(trim(VarName)) + 1
1445       VarNameAsInts( i ) = ICHAR( VarName(i-1:i-1) )
1446     ENDDO
1447     CALL store_piece_of_field_c ( inbuf, VarNameAsInts, Nbytes, ierr )
1448     IF ( ierr .NE. 0 ) CALL wrf_error_fatal ( "store_piece_of_field" )
1449     RETURN
1450   END SUBROUTINE store_piece_of_field
1451
1452   SUBROUTINE retrieve_pieces_of_field( outbuf, VarName, obufsz, Nbytes_tot, lret )
1453 !<DESCRIPTION>
1454 !<PRE>
1455 ! This routine is a wrapper for C routine retrieve_pieces_of_field_c() that
1456 ! is used to extract the entire contents (i.e. all previously stored pieces of
1457 ! fields) of the next internal buffer.  The name associated with this internal
1458 ! buffer is returned in VarName.  The number of bytes read is returned in
1459 ! Nbytes_tot.  Bytes are stored in outbuf whose size (in bytes) is obufsz.
1460 ! If there are more than obufsz bytes left in the next internal buffer, then
1461 ! only obufsz bytes are returned and the rest are discarded (probably an error
1462 ! in the making!).  The internal buffer is then freed.  Flag lret is set to
1463 ! .TRUE. iff there are more fields left to extract.
1464 !</PRE>
1465 !</DESCRIPTION>
1466     USE module_quilt_outbuf_ops
1467     IMPLICIT NONE
1468     INTEGER ,                INTENT(IN) :: obufsz
1469     INTEGER ,                INTENT(OUT) :: Nbytes_tot
1470     INTEGER , DIMENSION(*) , INTENT(OUT) :: outbuf
1471     CHARACTER*(*)    , INTENT(OUT) :: VarName
1472     LOGICAL                       :: lret   ! true if more, false if not
1473 ! Local
1474     CHARACTER*256         :: mess
1475     INTEGER               :: i, iret
1476     INTEGER               :: VarNameAsInts( 256 )
1477
1478     CALL retrieve_pieces_of_field_c ( outbuf, VarNameAsInts, obufsz, Nbytes_tot, iret )
1479     IF ( iret .NE.  0 ) THEN
1480        lret = .FALSE.
1481     ELSE
1482        lret = .TRUE.
1483        VarName = ' '
1484        DO i = 2, VarNameAsInts(1) + 1
1485          VarName(i-1:i-1) = CHAR(VarNameAsInts( i ))
1486        ENDDO
1487     ENDIF
1488     RETURN
1489   END SUBROUTINE retrieve_pieces_of_field
1490