frame/module_io.F

   1 !WRF:DRIVER_LAYER:IO
   2 !
   3 #define DEBUG_LVL 500
   4
   5 MODULE module_io
   6 !<DESCRIPTION>
   7 !<PRE>
   8 ! WRF-specific package-independent interface to package-dependent WRF-specific
   9 ! I/O packages.
  10 !
  11 ! These routines have the same names as those specified in the WRF I/O API
  12 ! except that:
  13 ! - Routines defined in this file and called by users of this module have
  14 !   the "wrf_" prefix.
  15 ! - Routines defined in the I/O packages and called from routines in this
  16 !   file have the "ext_" prefix.
  17 ! - Routines called from routines in this file to initiate communication
  18 !   with I/O quilt servers have the "wrf_quilt_" prefix.
  19 !
  20 ! See http://www.mmm.ucar.edu/wrf/WG2/software_2.0/IOAPI.doc for the latest
  21 ! version of the WRF I/O API.  This document includes detailed descriptions
  22 ! of subroutines and their arguments that are not duplicated in this file.
  23 !
  24 ! We wish to be able to link to different packages depending on whether
  25 ! the I/O is restart, initial, history, or boundary.
  26 !</PRE>
  27 !</DESCRIPTION>
  28
  29   USE module_configure
  30
  31   LOGICAL :: is_inited = .FALSE.
  32   INTEGER, PARAMETER, PRIVATE :: MAX_WRF_IO_HANDLE = 1000
  33   INTEGER :: wrf_io_handles(MAX_WRF_IO_HANDLE)
  34   INTEGER :: how_opened(MAX_WRF_IO_HANDLE)
  35   LOGICAL :: for_output(MAX_WRF_IO_HANDLE), first_operation(MAX_WRF_IO_HANDLE)
  36   INTEGER :: filtno = 0
  37   LOGICAL, PRIVATE :: bdy_dist_flag = .TRUE.   ! false is old style undecomposed boundary data structs,
  38                                                 ! true is new style decomposed boundary data structs
  39                                                 ! are_bdys_distributed, bdys_are_distributed and
  40                                                 ! bdys_not_distributed routines access this flag
  41   CHARACTER*256 extradims
  42
  43 !<DESCRIPTION>
  44 !<PRE>
  45 !
  46 ! include the file generated from md_calls.m4 using the m4 preprocessor
  47 ! note that this file also includes the CONTAINS declaration for the module
  48 !
  49 !</PRE>
  50 !</DESCRIPTION>
  51 #include "md_calls.inc"
  52
  53 !--- registry-generated routine that gets the io format being used for a dataset
  54
  55   INTEGER FUNCTION io_form_for_dataset ( DataSet )
  56     IMPLICIT NONE
  57     CHARACTER*(*), INTENT(IN)  :: DataSet
  58     INTEGER                    :: io_form
  59 #include "io_form_for_dataset.inc"
  60     io_form_for_dataset = io_form
  61     RETURN
  62   END FUNCTION io_form_for_dataset
  63
  64   INTEGER FUNCTION io_form_for_stream ( stream )
  65     USE module_streams
  66     IMPLICIT NONE
  67     INTEGER,       INTENT(IN)  :: stream
  68     INTEGER                    :: io_form
  69 #include "io_form_for_stream.inc"
  70     io_form_for_stream = io_form
  71     RETURN
  72   END FUNCTION io_form_for_stream
  73
  74 !--- ioinit
  75
  76 SUBROUTINE wrf_ioinit( Status )
  77 !<DESCRIPTION>
  78 !<PRE>
  79 ! Initialize the WRF I/O system.
  80 !</PRE>
  81 !</DESCRIPTION>
  82   IMPLICIT NONE
  83   INTEGER, INTENT(INOUT) :: Status
  84 !Local
  85   CHARACTER(len=80) :: SysDepInfo
  86   INTEGER :: ierr(100), minerr, maxerr
  87 !
  88   Status = 0
  89   ierr = 0
  90   SysDepInfo = " "
  91   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioinit' )
  92   CALL init_io_handles    ! defined below
  93 #ifdef NETCDF
  94   if ( model_config_rec%use_netcdf_classic ) SysDepInfo="use_netcdf_classic"
  95   CALL ext_ncd_ioinit  ( SysDepInfo, ierr( 1) )
  96   SysDepInfo = " "
  97 #endif
  98 #ifdef INTIO
  99   CALL ext_int_ioinit  ( SysDepInfo, ierr( 2) )
 100 #endif
 101 #ifdef PHDF5
 102   CALL ext_phdf5_ioinit( SysDepInfo, ierr( 3) )
 103 #endif
 104 #ifdef XXX
 105   CALL ext_xxx_ioinit  ( SysDepInfo, ierr( 5) )
 106 #endif
 107 #ifdef YYY
 108   CALL ext_yyy_ioinit  ( SysDepInfo, ierr( 6) )
 109 #endif
 110 #ifdef ZZZ
 111   CALL ext_zzz_ioinit  ( SysDepInfo, ierr( 7) )
 112 #endif
 113 #ifdef ESMFIO
 114   CALL ext_esmf_ioinit ( SysDepInfo, ierr( 8) )
 115 #endif
 116 #ifdef GRIB1
 117   CALL ext_gr1_ioinit  ( SysDepInfo, ierr( 9) )
 118 #endif
 119 #ifdef GRIB2
 120   CALL ext_gr2_ioinit  ( SysDepInfo, ierr(10) )
 121 #endif
 122 #ifdef PNETCDF
 123   CALL ext_pnc_ioinit  ( SysDepInfo, ierr(11) )
 124 #endif
 125 #ifdef PIO
 126   CALL ext_pio_ioinit  ( SysDepInfo, ierr(12) )
 127 #endif
 128 #ifdef NETCDFPAR
 129   CALL ext_ncdpar_ioinit( SysDepInfo, ierr(13) )
 130 #endif
 131 #ifdef ADIOS2
 132   CALL ext_adios2_ioinit  ( SysDepInfo, ierr(14) )
 133 #endif
 134
 135   minerr = MINVAL(ierr)
 136   maxerr = MAXVAL(ierr)
 137   IF ( minerr < 0 ) THEN
 138     Status = minerr
 139   ELSE IF ( maxerr > 0 ) THEN
 140     Status = maxerr
 141   ELSE
 142     Status = 0
 143   ENDIF
 144 END SUBROUTINE wrf_ioinit
 145
 146 !--- ioexit
 147
 148 SUBROUTINE wrf_ioexit( Status )
 149 !<DESCRIPTION>
 150 !<PRE>
 151 ! Shut down the WRF I/O system.
 152 !</PRE>
 153 !</DESCRIPTION>
 154   IMPLICIT NONE
 155   INTEGER, INTENT(INOUT) :: Status
 156 !Local
 157   LOGICAL, EXTERNAL :: use_output_servers
 158   INTEGER :: ierr(100), minerr, maxerr
 159 !
 160   Status = 0
 161   ierr = 0
 162   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioexit' )
 163 #ifdef NETCDF
 164   CALL ext_ncd_ioexit  ( ierr( 1) )
 165 #endif
 166 #ifdef INTIO
 167   CALL ext_int_ioexit  ( ierr( 2) )
 168 #endif
 169 #ifdef PHDF5
 170   CALL ext_phdf5_ioexit( ierr( 3) )
 171 #endif
 172 #ifdef XXX
 173   CALL ext_xxx_ioexit  ( ierr( 5) )
 174 #endif
 175 #ifdef YYY
 176   CALL ext_yyy_ioexit  ( ierr( 6) )
 177 #endif
 178 #ifdef ZZZ
 179   CALL ext_zzz_ioexit  ( ierr( 7) )
 180 #endif
 181 #ifdef ESMFIO
 182   CALL ext_esmf_ioexit ( ierr( 8) )
 183 #endif
 184 #ifdef GRIB1
 185   CALL ext_gr1_ioexit  ( ierr( 9) )
 186 #endif
 187 #ifdef GRIB2
 188   CALL ext_gr2_ioexit  ( ierr(10) )
 189 #endif
 190 #ifdef PNETCDF
 191   CALL ext_pnc_ioexit  ( ierr(11) )
 192 #endif
 193 #ifdef PIO
 194   CALL ext_pio_ioexit  ( ierr(12) )
 195 #endif
 196 #ifdef NETCDFPAR
 197   CALL ext_ncdpar_ioexit  ( ierr(13) )
 198 #endif
 199 #ifdef ADIOS2
 200   CALL ext_adios2_ioexit  ( ierr(14) )
 201 #endif
 202
 203   IF ( use_output_servers() ) THEN
 204       CALL wrf_quilt_ioexit( ierr(11) )
 205   ENDIF
 206   minerr = MINVAL(ierr)
 207   maxerr = MAXVAL(ierr)
 208   IF ( minerr < 0 ) THEN
 209     Status = minerr
 210   ELSE IF ( maxerr > 0 ) THEN
 211     Status = maxerr
 212   ELSE
 213     Status = 0
 214   ENDIF
 215 END SUBROUTINE wrf_ioexit
 216
 217 !--- open_for_write_begin
 218
 219 SUBROUTINE wrf_open_for_write_begin( FileName , grid, SysDepInfo, &
 220                                      DataHandle , Status )
 221 !<DESCRIPTION>
 222 !<PRE>
 223 ! Begin data definition ("training") phase for writing to WRF dataset
 224 ! FileName.
 225 !</PRE>
 226 !</DESCRIPTION>
 227   USE module_state_description
 228   USE module_domain
 229 #ifdef DM_PARALLEL
 230   USE module_dm, ONLY :  ntasks_x, mytask_x, local_communicator_x
 231 #endif
 232   IMPLICIT NONE
 233 #include "wrf_io_flags.h"
 234   CHARACTER*(*) :: FileName
 235   type(domain)                :: grid
 236   CHARACTER*(*), INTENT(INOUT):: SysDepInfo
 237   INTEGER ,       INTENT(OUT) :: DataHandle
 238   INTEGER ,       INTENT(OUT) :: Status
 239  !Local
 240   CHARACTER*128               :: DataSet
 241   INTEGER                     :: io_form
 242   INTEGER                     :: Hndl
 243   INTEGER, EXTERNAL           :: use_package
 244   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files
 245   LOGICAL, EXTERNAL :: use_output_servers_for
 246   CHARACTER*512     :: LocFilename   ! for appending the process ID if necessary
 247   INTEGER           :: myproc
 248   CHARACTER*512     :: mess
 249   CHARACTER (LEN=256)                    :: message
 250   CHARACTER*1028    :: tstr, t1
 251   INTEGER           :: i,j
 252   INTEGER           :: Comm_compute , Comm_io
 253   LOGICAL ncd_nofill
 254
 255   WRITE(mess,*) 'module_io.F: in wrf_open_for_write_begin, FileName = ',TRIM(FileName)
 256   CALL wrf_debug( 100, mess )
 257
 258   Comm_compute = grid%communicator
 259   Comm_io = grid%iocommunicator
 260
 261   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
 262
 263   CALL nl_get_ncd_nofill( 1 , ncd_nofill )
 264
 265   io_form = io_form_for_dataset( DataSet )
 266
 267   Status = 0
 268   Hndl = -1
 269   IF ( .not. use_output_servers_for(io_form) ) THEN
 270     SELECT CASE ( use_package(io_form) )
 271 #ifdef NETCDF
 272       CASE ( IO_NETCDF   )
 273         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 274           IF ( multi_files(io_form) ) THEN
 275             CALL wrf_get_myproc ( myproc )
 276             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 277           ELSE
 278             LocFilename = FileName
 279           ENDIF
 280           IF ( ncd_nofill ) THEN
 281             CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo // ",NOFILL=.TRUE.", &
 282                                                 Hndl , Status )
 283           ELSE
 284             CALL ext_ncd_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 285                                                 Hndl , Status )
 286           ENDIF
 287         ENDIF
 288         IF ( .NOT. multi_files(io_form) ) THEN
 289           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 290           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 291         ENDIF
 292
 293 #endif
 294 #ifdef NETCDFPAR
 295       CASE ( IO_NETCDFPAR   )
 296           IF ( ncd_nofill ) THEN
 297                CALL wrf_debug ( 100 , 'calling ext_ncdpar_open_for_write_begin 1' )
 298
 299             CALL ext_ncdpar_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo // ",NOFILL=.TRUE.", &
 300                                                 Hndl , Status )
 301               WRITE ( message , '("after ext_ncdpar_open_for_write_begin 1: status = ",i8)') status
 302
 303                CALL wrf_debug ( 100 , message )
 304           ELSE
 305                CALL wrf_debug ( 100 , 'calling ext_ncdpar_open_for_write_begin 2' )
 306             CALL ext_ncdpar_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 307                                                 Hndl , Status )
 308                CALL wrf_debug ( 100 , 'after ext_ncdpar_open_for_write_begin 1' )
 309           ENDIF
 310
 311 #endif
 312 #ifdef ADIOS2
 313       CASE (IO_ADIOS2  )
 314         WRITE(tstr,"(A,',ADIOS ADIOS NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") &
 315               TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x
 316         j=1
 317         t1 = " "
 318         DO i=1,len(TRIM(tstr))
 319           IF ( tstr(i:i) .NE. ' ' ) THEN
 320             t1(j:j) = tstr(i:i)
 321             j = j + 1
 322           ENDIF
 323         ENDDO
 324         tstr = t1
 325         CALL ext_adios2_open_for_write_begin( FileName, tstr,         &
 326                                             Dataset, Hndl, Status)
 327 #endif
 328
 329 #ifdef PHDF5
 330       CASE (IO_PHDF5  )
 331         CALL ext_phdf5_open_for_write_begin( FileName, Comm_compute, Comm_io, SysDepInfo, &
 332                                             Hndl, Status)
 333 #endif
 334 #ifdef PNETCDF
 335       CASE (IO_PNETCDF  )
 336         WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") &
 337               TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x
 338         j=1
 339         t1 = " "
 340         DO i=1,len(TRIM(tstr))
 341           IF ( tstr(i:i) .NE. ' ' ) THEN
 342             t1(j:j) = tstr(i:i)
 343             j = j + 1
 344           ENDIF
 345         ENDDO
 346         tstr = t1
 347         CALL ext_pnc_open_for_write_begin( FileName, Comm_compute, Comm_io, tstr, &
 348                                             Hndl, Status)
 349 #endif
 350 #ifdef PIO
 351       CASE ( IO_PIO )
 352         WRITE(tstr,"(A,',NTASKS_X=',i10,',MYTASK_X=',i10,',LOCAL_COMMUNICATOR_X=',i10)") &
 353               TRIM(SysDepInfo),ntasks_x,mytask_x,local_communicator_x
 354         j=1
 355         t1 = " "
 356         DO i=1,len(TRIM(tstr))
 357           IF ( tstr(i:i) .NE. ' ' ) THEN
 358             t1(j:j) = tstr(i:i)
 359             j = j + 1
 360           ENDIF
 361         ENDDO
 362         tstr = t1
 363         CALL ext_pio_open_for_write_begin( FileName, grid, tstr, Hndl, Status)
 364 #endif
 365 #ifdef XXX
 366       CASE ( IO_XXX   )
 367         CALL ext_xxx_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 368                                             Hndl , Status )
 369 #endif
 370 #ifdef YYY
 371       CASE ( IO_YYY   )
 372         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 373           IF ( multi_files(io_form) ) THEN
 374             CALL wrf_get_myproc ( myproc )
 375             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 376           ELSE
 377             LocFilename = FileName
 378           ENDIF
 379           CALL ext_yyy_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 380                                               Hndl , Status )
 381         ENDIF
 382         IF ( .NOT. multi_files(io_form) ) THEN
 383           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 384           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 385         ENDIF
 386 #endif
 387 #ifdef ZZZ
 388       CASE ( IO_ZZZ   )
 389         CALL ext_zzz_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 390                                             Hndl , Status )
 391 #endif
 392 #ifdef GRIB1
 393       CASE ( IO_GRIB1   )
 394         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 395           IF ( multi_files(io_form) ) THEN
 396             CALL wrf_get_myproc ( myproc )
 397             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 398           ELSE
 399             LocFilename = FileName
 400           ENDIF
 401           CALL ext_gr1_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 402                                               Hndl , Status )
 403         ENDIF
 404         IF ( .NOT. multi_files(io_form) ) THEN
 405           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 406           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 407         ENDIF
 408 #endif
 409 #ifdef GRIB2
 410       CASE ( IO_GRIB2   )
 411         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 412           IF ( multi_files(io_form) ) THEN
 413             CALL wrf_get_myproc ( myproc )
 414             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 415           ELSE
 416             LocFilename = FileName
 417           ENDIF
 418           CALL ext_gr2_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 419                                               Hndl , Status )
 420         ENDIF
 421         IF ( .NOT. multi_files(io_form) ) THEN
 422           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 423           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 424         ENDIF
 425 #endif
 426 #ifdef ESMFIO
 427       CASE ( IO_ESMF )
 428         CALL ext_esmf_open_for_write_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 429                                              Hndl , Status )
 430 #endif
 431 #ifdef INTIO
 432       CASE ( IO_INTIO   )
 433         IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 434           IF ( multi_files(io_form) ) THEN
 435             CALL wrf_get_myproc ( myproc )
 436             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 437           ELSE
 438             LocFilename = FileName
 439           ENDIF
 440           CALL ext_int_open_for_write_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 441                                               Hndl , Status )
 442         ENDIF
 443         IF ( .NOT. multi_files(io_form) ) THEN
 444           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 445           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 446         ENDIF
 447 #endif
 448       CASE DEFAULT
 449         IF ( io_form .NE. 0 ) THEN
 450           WRITE(mess,*)'Tried to open ',FileName,' writing: no valid io_form (',io_form,')'
 451           CALL wrf_debug(1, mess)
 452           Status = WRF_FILE_NOT_OPENED
 453         ENDIF
 454     END SELECT
 455   ELSE ! use_output_servers_for(io_form)
 456     IF ( io_form .GT. 0 ) THEN
 457       IF ( ncd_nofill ) THEN
 458         CALL wrf_quilt_open_for_write_begin ( FileName , grid%id, Comm_compute, Comm_io, TRIM(SysDepInfo) // ",NOFILL=.TRUE.", &
 459                                               Hndl , io_form, Status )
 460       ELSE
 461         CALL wrf_quilt_open_for_write_begin ( FileName , grid%id, Comm_compute, Comm_io, SysDepInfo, &
 462                                               Hndl , io_form, Status )
 463       ENDIF
 464     ENDIF
 465   ENDIF
 466   CALL add_new_handle( Hndl, io_form, .TRUE., DataHandle )
 467 END SUBROUTINE wrf_open_for_write_begin
 468
 469 !--- open_for_write_commit
 470
 471 SUBROUTINE wrf_open_for_write_commit( DataHandle , Status )
 472 !<DESCRIPTION>
 473 !<PRE>
 474 ! This routine switches an internal flag to enable output for the data set
 475 ! referenced by DataHandle. The call to wrf_open_for_write_commit() must be
 476 ! paired with a call to wrf_open_for_write_begin().
 477 !</PRE>
 478 !</DESCRIPTION>
 479   USE module_state_description
 480   IMPLICIT NONE
 481   INTEGER ,       INTENT(IN ) :: DataHandle
 482   INTEGER ,       INTENT(OUT) :: Status
 483
 484   CHARACTER (128)             :: DataSet
 485   INTEGER                     :: io_form
 486   INTEGER                     :: Hndl
 487   LOGICAL                     :: for_out
 488   INTEGER, EXTERNAL           :: use_package
 489   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
 490 #include "wrf_io_flags.h"
 491
 492   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_write_commit' )
 493
 494   Status = 0
 495   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
 496   CALL set_first_operation( DataHandle )
 497   IF ( Hndl .GT. -1 ) THEN
 498     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
 499       SELECT CASE ( use_package(io_form) )
 500 #ifdef NETCDF
 501         CASE ( IO_NETCDF   )
 502           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 503             CALL ext_ncd_open_for_write_commit ( Hndl , Status )
 504           ENDIF
 505           IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 506 #endif
 507 #ifdef NETCDFPAR
 508         CASE ( IO_NETCDFPAR   )
 509             CALL ext_ncdpar_open_for_write_commit ( Hndl , Status )
 510 #endif
 511 #ifdef ESMFIO
 512         CASE ( IO_ESMF )
 513           CALL ext_esmf_open_for_write_commit ( Hndl , Status )
 514 #endif
 515 #ifdef PHDF5
 516       CASE ( IO_PHDF5  )
 517         CALL ext_phdf5_open_for_write_commit ( Hndl , Status )
 518 #endif
 519 #ifdef PNETCDF
 520       CASE ( IO_PNETCDF  )
 521         CALL ext_pnc_open_for_write_commit ( Hndl , Status )
 522 #endif
 523 #ifdef ADIOS2
 524       CASE ( IO_ADIOS2  )
 525         CALL ext_adios2_open_for_write_commit ( Hndl , Status )
 526 #endif
 527 #ifdef PIO
 528       CASE ( IO_PIO )
 529         CALL ext_pio_open_for_write_commit ( Hndl , Status )
 530 #endif
 531 #ifdef XXX
 532       CASE ( IO_XXX   )
 533         CALL ext_xxx_open_for_write_commit ( Hndl , Status )
 534 #endif
 535 #ifdef YYY
 536       CASE ( IO_YYY   )
 537          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 538             CALL ext_yyy_open_for_write_commit ( Hndl , Status )
 539          ENDIF
 540          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 541 #endif
 542 #ifdef ZZZ
 543       CASE ( IO_ZZZ   )
 544         CALL ext_zzz_open_for_write_commit ( Hndl , Status )
 545 #endif
 546 #ifdef GRIB1
 547       CASE ( IO_GRIB1   )
 548          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 549             CALL ext_gr1_open_for_write_commit ( Hndl , Status )
 550          ENDIF
 551          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 552 #endif
 553 #ifdef GRIB2
 554       CASE ( IO_GRIB2   )
 555          IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 556             CALL ext_gr2_open_for_write_commit ( Hndl , Status )
 557          ENDIF
 558          IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 559 #endif
 560 #ifdef INTIO
 561       CASE ( IO_INTIO   )
 562         CALL ext_int_open_for_write_commit ( Hndl , Status )
 563 #endif
 564         CASE DEFAULT
 565           Status = 0
 566       END SELECT
 567     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
 568       CALL wrf_quilt_open_for_write_commit ( Hndl , Status )
 569     ELSE
 570       Status = 0
 571     ENDIF
 572   ELSE
 573     Status = 0
 574   ENDIF
 575   RETURN
 576 END SUBROUTINE wrf_open_for_write_commit
 577
 578 !--- open_for_read_begin
 579
 580 SUBROUTINE wrf_open_for_read_begin( FileName , grid, SysDepInfo, &
 581                                      DataHandle , Status )
 582 !<DESCRIPTION>
 583 !<PRE>
 584 ! Begin data definition ("training") phase for reading from WRF dataset
 585 ! FileName.
 586 !</PRE>
 587 !</DESCRIPTION>
 588   USE module_state_description
 589   USE module_domain
 590   IMPLICIT NONE
 591 #include "wrf_io_flags.h"
 592   CHARACTER*(*) :: FileName
 593   TYPE (domain) :: grid
 594   CHARACTER*(*) :: SysDepInfo
 595   INTEGER ,       INTENT(OUT) :: DataHandle
 596   INTEGER ,       INTENT(OUT) :: Status
 597
 598   CHARACTER*128               :: DataSet
 599   INTEGER                     :: io_form
 600   INTEGER                     :: Hndl
 601   LOGICAL                     :: also_for_out
 602   INTEGER, EXTERNAL           :: use_package
 603   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
 604
 605   CHARACTER*128     :: LocFilename   ! for appending the process ID if necessary
 606   INTEGER     myproc
 607   CHARACTER*128     :: mess, fhand
 608   CHARACTER*1028    :: tstr
 609   INTEGER           :: Comm_compute , Comm_io
 610
 611   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_begin' )
 612
 613   Comm_compute = grid%communicator
 614   Comm_io = grid%iocommunicator
 615
 616   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
 617
 618   io_form = io_form_for_dataset( DataSet )
 619
 620   Status = 0
 621   Hndl = -1
 622   also_for_out = .FALSE.
 623 !  IF ( .NOT. use_output_servers_for(io_form) ) THEN
 624     SELECT CASE ( use_package(io_form) )
 625 #ifdef NETCDF
 626       CASE ( IO_NETCDF   )
 627         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 628           IF ( multi_files(io_form) ) THEN
 629               CALL wrf_get_myproc ( myproc )
 630               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 631           ELSE
 632               LocFilename = FileName
 633           ENDIF
 634           CALL ext_ncd_open_for_read_begin ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
 635                                        Hndl , Status )
 636         ENDIF
 637         IF ( .NOT. multi_files(io_form) ) THEN
 638           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 639           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 640         ENDIF
 641 #endif
 642 #ifdef NETCDFPAR
 643       CASE ( IO_NETCDFPAR   )
 644         CALL ext_ncdpar_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 645                                             Hndl , Status )
 646 #endif
 647 #ifdef PNETCDF
 648       CASE ( IO_PNETCDF   )
 649         CALL ext_pnc_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 650                                             Hndl , Status )
 651 #endif
 652 #ifdef ADIOS2
 653       CASE ( IO_ADIOS2   )
 654         CALL ext_adios2_open_for_read_begin ( FileName , SysDepInfo, &
 655                                             Hndl , Status )
 656 #endif
 657 #ifdef PIO
 658       CASE ( IO_PIO )
 659         CALL ext_pio_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 660                                             Hndl , Status )
 661 #endif
 662 #ifdef XXX
 663       CASE ( IO_XXX   )
 664         CALL ext_xxx_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 665                                             Hndl , Status )
 666 #endif
 667 #ifdef YYY
 668       CASE ( IO_YYY   )
 669         CALL ext_yyy_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 670                                             Hndl , Status )
 671 #endif
 672 #ifdef ZZZ
 673       CASE ( IO_ZZZ   )
 674         CALL ext_zzz_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 675                                             Hndl , Status )
 676 #endif
 677 #ifdef ESMFIO
 678       CASE ( IO_ESMF )
 679         also_for_out = .TRUE.
 680         CALL ext_esmf_open_for_read_begin ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 681                                             Hndl , Status )
 682 #endif
 683 #ifdef GRIB1
 684       CASE ( IO_GRIB1   )
 685         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 686           IF ( multi_files(io_form) ) THEN
 687               CALL wrf_get_myproc ( myproc )
 688               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 689           ELSE
 690               LocFilename = FileName
 691           ENDIF
 692           CALL ext_gr1_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 693                Hndl , Status )
 694         ENDIF
 695         IF ( .NOT. multi_files(io_form) ) THEN
 696           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 697           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 698         ENDIF
 699 #endif
 700 #ifdef GRIB2
 701       CASE ( IO_GRIB2   )
 702         IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 703           IF ( multi_files(io_form) ) THEN
 704               CALL wrf_get_myproc ( myproc )
 705               CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 706           ELSE
 707               LocFilename = FileName
 708           ENDIF
 709           CALL ext_gr2_open_for_read_begin ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 710                Hndl , Status )
 711         ENDIF
 712         IF ( .NOT. multi_files(io_form) ) THEN
 713           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 714           CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 715         ENDIF
 716 #endif
 717 #ifdef INTIO
 718       CASE ( IO_INTIO   )
 719 #endif
 720       CASE DEFAULT
 721         IF ( io_form .NE. 0 ) THEN
 722           WRITE(mess,*)'Tried to open ',FileName,' reading: no valid io_form (',io_form,')'
 723           CALL wrf_message(mess)
 724         ENDIF
 725         Status = WRF_FILE_NOT_OPENED
 726     END SELECT
 727 !  ELSE
 728 !    Status = 0
 729 !  ENDIF
 730   CALL add_new_handle( Hndl, io_form, also_for_out, DataHandle )
 731 END SUBROUTINE wrf_open_for_read_begin
 732
 733 !--- open_for_read_commit
 734
 735 SUBROUTINE wrf_open_for_read_commit( DataHandle , Status )
 736 !<DESCRIPTION>
 737 !<PRE>
 738 ! End "training" phase for WRF dataset FileName.  The call to
 739 ! wrf_open_for_read_commit() must be paired with a call to
 740 ! wrf_open_for_read_begin().
 741 !</PRE>
 742 !</DESCRIPTION>
 743   USE module_state_description
 744   IMPLICIT NONE
 745   INTEGER ,       INTENT(IN ) :: DataHandle
 746   INTEGER ,       INTENT(OUT) :: Status
 747
 748   CHARACTER (128)             :: DataSet
 749   INTEGER                     :: io_form
 750   INTEGER                     :: Hndl
 751   LOGICAL                     :: for_out
 752   INTEGER, EXTERNAL           :: use_package
 753   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
 754 #include "wrf_io_flags.h"
 755
 756   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read_commit' )
 757
 758   Status = 0
 759   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
 760   CALL set_first_operation( DataHandle )
 761   IF ( Hndl .GT. -1 ) THEN
 762     IF ( .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
 763       SELECT CASE ( use_package(io_form) )
 764 #ifdef NETCDF
 765         CASE ( IO_NETCDF   )
 766           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) THEN
 767             CALL ext_ncd_open_for_read_commit ( Hndl , Status )
 768           ENDIF
 769           IF ( .NOT. multi_files(io_form) ) CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 770 #endif
 771 #ifdef ESMFIO
 772         CASE ( IO_ESMF )
 773           CALL ext_esmf_open_for_read_commit ( Hndl , Status )
 774 #endif
 775 #ifdef NETCDFPAR
 776         CASE ( IO_NETCDFPAR )
 777           CALL ext_ncdpar_open_for_read_commit ( Hndl , Status )
 778 #endif
 779 #ifdef PNETCDF
 780         CASE ( IO_PNETCDF )
 781           CALL ext_pnc_open_for_read_commit ( Hndl , Status )
 782 #endif
 783 #ifdef ADIOS2
 784         CASE ( IO_ADIOS2 )
 785           CALL ext_adios2_open_for_read_commit ( Hndl , Status )
 786 #endif
 787 #ifdef PIO
 788         CASE ( IO_PIO )
 789           CALL ext_pio_open_for_read_commit ( Hndl , Status )
 790 #endif
 791 #ifdef XXX
 792       CASE ( IO_XXX   )
 793         CALL ext_xxx_open_for_read_commit ( Hndl , Status )
 794 #endif
 795 #ifdef YYY
 796       CASE ( IO_YYY   )
 797         CALL ext_yyy_open_for_read_commit ( Hndl , Status )
 798 #endif
 799 #ifdef ZZZ
 800       CASE ( IO_ZZZ   )
 801         CALL ext_zzz_open_for_read_commit ( Hndl , Status )
 802 #endif
 803 #ifdef GRIB1
 804       CASE ( IO_GRIB1   )
 805         CALL ext_gr1_open_for_read_commit ( Hndl , Status )
 806 #endif
 807 #ifdef GRIB2
 808       CASE ( IO_GRIB2   )
 809         CALL ext_gr2_open_for_read_commit ( Hndl , Status )
 810 #endif
 811 #ifdef INTIO
 812       CASE ( IO_INTIO   )
 813 #endif
 814         CASE DEFAULT
 815           Status = 0
 816       END SELECT
 817     ELSE
 818       Status = 0
 819     ENDIF
 820   ELSE
 821     Status = WRF_FILE_NOT_OPENED
 822   ENDIF
 823   RETURN
 824 END SUBROUTINE wrf_open_for_read_commit
 825
 826 !--- open_for_read
 827
 828 SUBROUTINE wrf_open_for_read ( FileName , grid, SysDepInfo, &
 829                                DataHandle , Status )
 830 !<DESCRIPTION>
 831 !<PRE>
 832 ! Opens a WRF dataset for reading.
 833 !</PRE>
 834 !</DESCRIPTION>
 835   USE module_state_description
 836   USE module_domain
 837   IMPLICIT NONE
 838   CHARACTER*(*) :: FileName
 839   TYPE (domain) :: grid
 840   CHARACTER*(*) :: SysDepInfo
 841   INTEGER ,       INTENT(OUT) :: DataHandle
 842   INTEGER ,       INTENT(OUT) :: Status
 843
 844   CHARACTER (128)             :: DataSet, LocFileName
 845   INTEGER                     :: io_form, myproc
 846   INTEGER                     :: Hndl
 847   INTEGER, EXTERNAL           :: use_package
 848   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
 849   INTEGER                     :: Comm_compute, Comm_io
 850
 851   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_open_for_read' )
 852
 853   Comm_compute = grid%communicator
 854   Comm_io = grid%iocommunicator
 855
 856   CALL get_value_from_pairs ( "DATASET" , SysDepInfo , DataSet )
 857
 858   io_form = io_form_for_dataset( DataSet )
 859
 860   Hndl = -1
 861   Status = 0
 862   SELECT CASE ( use_package(io_form) )
 863 #ifdef NETCDF
 864     CASE ( IO_NETCDF   )
 865       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 866         IF ( multi_files(io_form) ) THEN
 867             CALL wrf_get_myproc ( myproc )
 868             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 869         ELSE
 870             LocFilename = FileName
 871         ENDIF
 872
 873         CALL ext_ncd_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
 874                                      Hndl , Status )
 875       ENDIF
 876       IF ( .NOT. multi_files(io_form) ) THEN
 877         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 878         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 879       ENDIF
 880 #endif
 881 #ifdef NETCDFPAR
 882     CASE ( IO_NETCDFPAR  )
 883       CALL ext_ncdpar_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 884                                Hndl , Status )
 885 #endif
 886 #ifdef PNETCDF
 887     CASE ( IO_PNETCDF  )
 888       CALL ext_pnc_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 889                                Hndl , Status )
 890 #endif
 891 #ifdef ADIOS2
 892     CASE ( IO_ADIOS2  )
 893       CALL ext_adios2_open_for_read ( FileName , SysDepInfo, &
 894                                Hndl , Status )
 895 #endif
 896 #ifdef PIO
 897     CASE ( IO_PIO )
 898       CALL ext_pio_open_for_read ( FileName , grid, SysDepInfo, Hndl , Status )
 899 #endif
 900 #ifdef PHDF5
 901     CASE ( IO_PHDF5  )
 902       CALL ext_phdf5_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 903                                Hndl , Status )
 904 #endif
 905 #ifdef XXX
 906     CASE ( IO_XXX   )
 907       CALL ext_xxx_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 908                                Hndl , Status )
 909 #endif
 910 #ifdef YYY
 911     CASE ( IO_YYY   )
 912       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 913         IF ( multi_files(io_form) ) THEN
 914             CALL wrf_get_myproc ( myproc )
 915             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 916         ELSE
 917             LocFilename = FileName
 918         ENDIF
 919
 920         CALL ext_yyy_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
 921                                      Hndl , Status )
 922       ENDIF
 923       IF ( .NOT. multi_files(io_form) ) THEN
 924         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 925         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 926       ENDIF
 927 #endif
 928 #ifdef ZZZ
 929     CASE ( IO_ZZZ   )
 930       CALL ext_zzz_open_for_read ( FileName , Comm_compute, Comm_io, SysDepInfo, &
 931                                Hndl , Status )
 932 #endif
 933 #ifdef GRIB1
 934     CASE ( IO_GRIB1   )
 935       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 936         IF ( multi_files(io_form) ) THEN
 937             CALL wrf_get_myproc ( myproc )
 938             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 939         ELSE
 940             LocFilename = FileName
 941         ENDIF
 942
 943         CALL ext_gr1_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
 944                                      Hndl , Status )
 945       ENDIF
 946       IF ( .NOT. multi_files(io_form) ) THEN
 947         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 948         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 949       ENDIF
 950 #endif
 951 #ifdef GRIB2
 952     CASE ( IO_GRIB2   )
 953       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 954         IF ( multi_files(io_form) ) THEN
 955             CALL wrf_get_myproc ( myproc )
 956             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 957         ELSE
 958             LocFilename = FileName
 959         ENDIF
 960
 961         CALL ext_gr2_open_for_read ( LocFilename , Comm_compute, Comm_io, SysDepInfo, &
 962                                      Hndl , Status )
 963       ENDIF
 964       IF ( .NOT. multi_files(io_form) ) THEN
 965         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 966         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 967       ENDIF
 968 #endif
 969 #ifdef INTIO
 970     CASE ( IO_INTIO   )
 971       IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) THEN
 972         IF ( multi_files(io_form) ) THEN
 973             CALL wrf_get_myproc ( myproc )
 974             CALL append_to_filename ( LocFilename , FileName , myproc, 4 )
 975         ELSE
 976             LocFilename = FileName
 977         ENDIF
 978         CALL ext_int_open_for_read ( LocFileName , Comm_compute, Comm_io, SysDepInfo, &
 979                                      Hndl , Status )
 980       ENDIF
 981       IF ( .NOT. multi_files(io_form) ) THEN
 982         CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
 983         CALL wrf_dm_bcast_bytes( Hndl, IWORDSIZE )
 984       ENDIF
 985 #endif
 986     CASE DEFAULT
 987         Status = 0
 988   END SELECT
 989   CALL add_new_handle( Hndl, io_form, .FALSE., DataHandle )
 990   RETURN
 991 END SUBROUTINE wrf_open_for_read
 992
 993 !--- inquire_opened
 994
 995 SUBROUTINE wrf_inquire_opened ( DataHandle, FileName , FileStatus, Status )
 996 !<DESCRIPTION>
 997 !<PRE>
 998 ! Inquire if the dataset referenced by DataHandle is open.
 999 !</PRE>
1000 !</DESCRIPTION>
1001   USE module_state_description
1002   IMPLICIT NONE
1003   INTEGER ,       INTENT(IN)  :: DataHandle
1004   CHARACTER*(*) :: FileName
1005   INTEGER ,       INTENT(OUT) :: FileStatus
1006   INTEGER ,       INTENT(OUT) :: Status
1007   LOGICAL                     :: for_out
1008   INTEGER, EXTERNAL           :: use_package
1009   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1010 #include "wrf_io_flags.h"
1011 #include "wrf_status_codes.h"
1012
1013   INTEGER io_form
1014   INTEGER            :: Hndl
1015
1016   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_inquire_opened' )
1017
1018   Status = 0
1019   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1020   IF ( Hndl .GT. -1 ) THEN
1021     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1022       SELECT CASE ( use_package(io_form) )
1023 #ifdef NETCDF
1024         CASE ( IO_NETCDF   )
1025           IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_opened ( Hndl, FileName , FileStatus, Status )
1026           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1027           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1028 #endif
1029 #ifdef NETCDFPAR
1030         CASE ( IO_NETCDFPAR   )
1031            CALL ext_ncdpar_inquire_opened ( Hndl, FileName , FileStatus, Status )
1032 #endif
1033 #ifdef PHDF5
1034       CASE ( IO_PHDF5   )
1035           CALL ext_phdf5_inquire_opened ( Hndl, FileName , FileStatus, Status )
1036 #endif
1037 #ifdef PNETCDF
1038       CASE ( IO_PNETCDF   )
1039           CALL ext_pnc_inquire_opened ( Hndl, FileName , FileStatus, Status )
1040 #endif
1041 #ifdef ADIOS2
1042       CASE ( IO_ADIOS2   )
1043           CALL ext_adios2_inquire_opened ( Hndl, FileName , FileStatus, Status )
1044 #endif
1045 #ifdef PIO
1046       CASE ( IO_PIO )
1047           CALL ext_pio_inquire_opened ( Hndl, FileName , FileStatus, Status )
1048 #endif
1049 #ifdef XXX
1050       CASE ( IO_XXX   )
1051           CALL ext_xxx_inquire_opened ( Hndl, FileName , FileStatus, Status )
1052 #endif
1053 #ifdef YYY
1054       CASE ( IO_YYY   )
1055           IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_opened ( Hndl, FileName , FileStatus, Status )
1056           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1057           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1058 #endif
1059 #ifdef ZZZ
1060       CASE ( IO_ZZZ   )
1061           CALL ext_zzz_inquire_opened ( Hndl, FileName , FileStatus, Status )
1062 #endif
1063 #ifdef GRIB1
1064       CASE ( IO_GRIB1   )
1065           IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_opened ( Hndl, FileName , FileStatus, Status )
1066           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1067           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1068 #endif
1069 #ifdef GRIB2
1070       CASE ( IO_GRIB2   )
1071           IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_opened ( Hndl, FileName , FileStatus, Status )
1072           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1073           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1074 #endif
1075 #ifdef INTIO
1076       CASE ( IO_INTIO   )
1077           IF (wrf_dm_on_monitor()) CALL ext_int_inquire_opened ( Hndl, FileName , FileStatus, Status )
1078           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1079           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1080 #endif
1081         CASE DEFAULT
1082           FileStatus = WRF_FILE_NOT_OPENED
1083           Status = 0
1084       END SELECT
1085     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1086       CALL wrf_quilt_inquire_opened ( Hndl, FileName , FileStatus, Status )
1087     ENDIF
1088   ELSE
1089     FileStatus = WRF_FILE_NOT_OPENED
1090     Status = 0
1091   ENDIF
1092   RETURN
1093 END SUBROUTINE wrf_inquire_opened
1094
1095 !--- inquire_filename
1096
1097
1098 SUBROUTINE wrf_inquire_filename ( DataHandle, FileName , FileStatus, Status )
1099 !<DESCRIPTION>
1100 !<PRE>
1101 ! Returns the Filename and FileStatus associated with DataHandle.
1102 !</PRE>
1103 !</DESCRIPTION>
1104   USE module_state_description
1105   IMPLICIT NONE
1106   INTEGER ,       INTENT(IN)  :: DataHandle
1107   CHARACTER*(*) :: FileName
1108   INTEGER ,       INTENT(OUT) :: FileStatus
1109   INTEGER ,       INTENT(OUT) :: Status
1110 #include "wrf_status_codes.h"
1111   INTEGER, EXTERNAL           :: use_package
1112   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1113   LOGICAL                     :: for_out
1114
1115   INTEGER                     :: io_form
1116   INTEGER                     :: str_length , str_count
1117   INTEGER                     :: Hndl
1118
1119   CALL wrf_debug( 300, 'module_io.F: in wrf_inquire_filename' )
1120
1121   Status = 0
1122   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1123
1124   IF ( Hndl .GT. -1 ) THEN
1125     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1126       SELECT CASE ( use_package( io_form ) )
1127 #ifdef NETCDF
1128         CASE ( IO_NETCDF   )
1129           str_length = LEN ( FileName )
1130           DO str_count = 1 , str_length
1131             FileName(str_count:str_count) = ' '
1132           END DO
1133           IF (wrf_dm_on_monitor()) CALL ext_ncd_inquire_filename ( Hndl, FileName , FileStatus, Status )
1134           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1135           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1136 #endif
1137 #ifdef NETCDFPAR
1138         CASE ( IO_NETCDFPAR   )
1139           CALL ext_ncdpar_inquire_filename ( Hndl, FileName , FileStatus, Status )
1140 #endif
1141 #ifdef PHDF5
1142         CASE ( IO_PHDF5   )
1143           CALL ext_phdf5_inquire_filename ( Hndl, FileName , FileStatus, Status )
1144 #endif
1145 #ifdef PNETCDF
1146         CASE ( IO_PNETCDF   )
1147           CALL ext_pnc_inquire_filename ( Hndl, FileName , FileStatus, Status )
1148 #endif
1149 #ifdef ADIOS2
1150         CASE ( IO_ADIOS2   )
1151           CALL ext_adios2_inquire_filename ( Hndl, FileName , FileStatus, Status )
1152 #endif
1153 #ifdef PIO
1154         CASE ( IO_PIO )
1155           CALL ext_pio_inquire_filename ( Hndl, FileName , FileStatus, Status )
1156 #endif
1157 #ifdef XXX
1158         CASE ( IO_XXX   )
1159           CALL ext_xxx_inquire_filename ( Hndl, FileName , FileStatus, Status )
1160 #endif
1161 #ifdef YYY
1162         CASE ( IO_YYY   )
1163           IF (wrf_dm_on_monitor()) CALL ext_yyy_inquire_filename ( Hndl, FileName , FileStatus, Status )
1164           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1165           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1166 #endif
1167 #ifdef ZZZ
1168         CASE ( IO_ZZZ   )
1169             CALL ext_zzz_inquire_filename ( Hndl, FileName , FileStatus, Status )
1170 #endif
1171 #ifdef GRIB1
1172         CASE ( IO_GRIB1   )
1173           IF (wrf_dm_on_monitor()) CALL ext_gr1_inquire_filename ( Hndl, FileName , FileStatus, Status )
1174           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1175           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1176 #endif
1177 #ifdef GRIB2
1178         CASE ( IO_GRIB2   )
1179           IF (wrf_dm_on_monitor()) CALL ext_gr2_inquire_filename ( Hndl, FileName , FileStatus, Status )
1180           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1181           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1182 #endif
1183 #ifdef INTIO
1184         CASE ( IO_INTIO   )
1185           IF (wrf_dm_on_monitor()) CALL ext_int_inquire_filename ( Hndl, FileName , FileStatus, Status )
1186           CALL wrf_dm_bcast_bytes( FileStatus, IWORDSIZE )
1187           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1188 #endif
1189         CASE DEFAULT
1190           Status = 0
1191       END SELECT
1192     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1193       CALL wrf_quilt_inquire_filename ( Hndl, FileName , FileStatus, Status )
1194     ENDIF
1195   ELSE
1196     FileName = ""
1197     Status = 0
1198   ENDIF
1199   RETURN
1200 END SUBROUTINE wrf_inquire_filename
1201
1202 !--- sync
1203
1204 SUBROUTINE wrf_iosync ( DataHandle, Status )
1205 !<DESCRIPTION>
1206 !<PRE>
1207 ! Synchronize the disk copy of a dataset with memory buffers.
1208 !</PRE>
1209 !</DESCRIPTION>
1210   USE module_state_description
1211   IMPLICIT NONE
1212   INTEGER ,       INTENT(IN)  :: DataHandle
1213   INTEGER ,       INTENT(OUT) :: Status
1214 #include "wrf_status_codes.h"
1215   INTEGER, EXTERNAL           :: use_package
1216   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1217   LOGICAL                     :: for_out
1218
1219   INTEGER                     :: io_form
1220   INTEGER                     :: Hndl
1221
1222   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_iosync' )
1223
1224   Status = 0
1225   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1226   IF ( Hndl .GT. -1 ) THEN
1227     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1228       SELECT CASE ( use_package(io_form) )
1229 #ifdef NETCDF
1230         CASE ( IO_NETCDF   )
1231           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_ncd_iosync( Hndl, Status )
1232           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1233 #endif
1234 #ifdef XXX
1235         CASE ( IO_XXX   )
1236           CALL ext_xxx_iosync( Hndl, Status )
1237 #endif
1238 #ifdef YYY
1239         CASE ( IO_YYY   )
1240           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_yyy_iosync( Hndl, Status )
1241           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1242 #endif
1243 #ifdef GRIB1
1244         CASE ( IO_GRIB1   )
1245           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr1_iosync( Hndl, Status )
1246           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1247 #endif
1248 #ifdef GRIB2
1249         CASE ( IO_GRIB2   )
1250           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_gr2_iosync( Hndl, Status )
1251           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1252 #endif
1253 #ifdef ZZZ
1254         CASE ( IO_ZZZ   )
1255           CALL ext_zzz_iosync( Hndl, Status )
1256 #endif
1257 #ifdef INTIO
1258         CASE ( IO_INTIO   )
1259           IF ( multi_files(io_form) .OR. wrf_dm_on_monitor() ) CALL ext_int_iosync( Hndl, Status )
1260           CALL wrf_dm_bcast_bytes( Status    , IWORDSIZE )
1261 #endif
1262         CASE DEFAULT
1263           Status = 0
1264       END SELECT
1265     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1266       CALL wrf_quilt_iosync( Hndl, Status )
1267     ELSE
1268       Status = 0
1269     ENDIF
1270   ELSE
1271     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1272   ENDIF
1273   RETURN
1274 END SUBROUTINE wrf_iosync
1275
1276 !--- close
1277
1278 SUBROUTINE wrf_ioclose ( DataHandle, Status )
1279 !<DESCRIPTION>
1280 !<PRE>
1281 ! Close the dataset referenced by DataHandle.
1282 !</PRE>
1283 !</DESCRIPTION>
1284   USE module_state_description
1285   IMPLICIT NONE
1286   INTEGER ,       INTENT(IN)  :: DataHandle
1287   INTEGER ,       INTENT(OUT) :: Status
1288 #include "wrf_status_codes.h"
1289   INTEGER, EXTERNAL           :: use_package
1290   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1291   INTEGER                     :: io_form
1292   LOGICAL                     :: for_out
1293   INTEGER                     :: Hndl
1294
1295   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_ioclose' )
1296
1297   Status = 0
1298   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1299   CALL free_handle( DataHandle )
1300   IF ( Hndl .GT. -1 ) THEN
1301     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1302       SELECT CASE ( use_package(io_form) )
1303 #ifdef NETCDF
1304         CASE ( IO_NETCDF   )
1305           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_ioclose( Hndl, Status )
1306           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1307 #endif
1308 #ifdef NETCDFPAR
1309         CASE ( IO_NETCDFPAR  )
1310           CALL ext_ncdpar_ioclose( Hndl, Status )
1311 #endif
1312 #ifdef PHDF5
1313         CASE ( IO_PHDF5  )
1314           CALL ext_phdf5_ioclose( Hndl, Status )
1315 #endif
1316 #ifdef PNETCDF
1317         CASE ( IO_PNETCDF  )
1318           CALL ext_pnc_ioclose( Hndl, Status )
1319 #endif
1320 #ifdef ADIOS2
1321         CASE ( IO_ADIOS2  )
1322           CALL ext_adios2_ioclose( Hndl, Status )
1323 #endif
1324 #ifdef PIO
1325         CASE ( IO_PIO )
1326           CALL ext_pio_ioclose( Hndl, Status )
1327 #endif
1328 #ifdef XXX
1329         CASE ( IO_XXX   )
1330           CALL ext_xxx_ioclose( Hndl, Status )
1331 #endif
1332 #ifdef YYY
1333         CASE ( IO_YYY   )
1334           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_ioclose( Hndl, Status )
1335           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1336 #endif
1337 #ifdef ZZZ
1338         CASE ( IO_ZZZ   )
1339           CALL ext_zzz_ioclose( Hndl, Status )
1340 #endif
1341 #ifdef GRIB1
1342         CASE ( IO_GRIB1   )
1343           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_ioclose( Hndl, Status )
1344           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1345 #endif
1346 #ifdef GRIB2
1347         CASE ( IO_GRIB2   )
1348           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_ioclose( Hndl, Status )
1349           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1350 #endif
1351 #ifdef ESMFIO
1352         CASE ( IO_ESMF )
1353           CALL ext_esmf_ioclose( Hndl, Status )
1354 #endif
1355 #ifdef INTIO
1356         CASE ( IO_INTIO   )
1357           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_ioclose( Hndl, Status )
1358           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1359 #endif
1360         CASE DEFAULT
1361           Status = 0
1362       END SELECT
1363     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1364       CALL wrf_quilt_ioclose( Hndl, Status )
1365     ELSE
1366       Status = 0
1367     ENDIF
1368   ELSE
1369     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1370   ENDIF
1371   RETURN
1372 END SUBROUTINE wrf_ioclose
1373
1374 !--- get_next_time (not defined for IntIO )
1375
1376 SUBROUTINE wrf_get_next_time ( DataHandle, DateStr, Status )
1377 !<DESCRIPTION>
1378 !<PRE>
1379 ! Returns the next time stamp.
1380 !</PRE>
1381 !</DESCRIPTION>
1382   USE module_state_description
1383   IMPLICIT NONE
1384   INTEGER ,       INTENT(IN)  :: DataHandle
1385   CHARACTER*(*) :: DateStr
1386   INTEGER ,       INTENT(OUT) :: Status
1387 #include "wrf_status_codes.h"
1388
1389   INTEGER, EXTERNAL           :: use_package
1390   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1391   INTEGER                     :: io_form, len_of_str
1392   LOGICAL                     :: for_out
1393   INTEGER                     :: Hndl
1394
1395   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_time' )
1396
1397   Status = 0
1398   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1399   IF ( Hndl .GT. -1 ) THEN
1400     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1401       SELECT CASE ( use_package(io_form) )
1402 #ifdef NETCDF
1403         CASE ( IO_NETCDF   )
1404           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_next_time( Hndl, DateStr, Status )
1405           IF ( .NOT. multi_files(io_form) ) THEN
1406             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1407             len_of_str = LEN(DateStr)
1408             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1409           ENDIF
1410 #endif
1411 #ifdef PNETCDF
1412         CASE ( IO_PNETCDF   )
1413           IF ( multi_files(io_form) ) THEN
1414             CALL ext_pnc_get_next_time( Hndl, DateStr, Status )
1415           ELSE
1416             IF ( wrf_dm_on_monitor() ) THEN
1417               CALL ext_pnc_get_next_time( Hndl, DateStr, Status )
1418             ENDIF
1419
1420             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1421             len_of_str = LEN(DateStr)
1422             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1423           ENDIF
1424 #endif
1425 #ifdef PIO
1426         CASE ( IO_PIO )
1427           IF ( multi_files(io_form) ) THEN
1428             CALL ext_pio_get_next_time( Hndl, DateStr, Status )
1429           ELSE
1430             IF ( wrf_dm_on_monitor() ) THEN
1431               CALL ext_pio_get_next_time( Hndl, DateStr, Status )
1432             ENDIF
1433
1434             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1435             len_of_str = LEN(DateStr)
1436             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1437           ENDIF
1438 #endif
1439 #ifdef ADIOS2
1440         CASE ( IO_ADIOS2   )
1441           CALL ext_adios2_get_next_time( Hndl, DateStr, Status )
1442 #endif
1443 #ifdef PHDF5
1444         CASE ( IO_PHDF5   )
1445           CALL ext_phdf5_get_next_time( Hndl, DateStr, Status )
1446 #endif
1447 #ifdef NETCDFPAR
1448         CASE ( IO_NETCDFPAR   )
1449           CALL ext_ncdpar_get_next_time( Hndl, DateStr, Status )
1450 #endif
1451 #ifdef XXX
1452         CASE ( IO_XXX   )
1453           CALL ext_xxx_get_next_time( Hndl, DateStr, Status )
1454 #endif
1455 #ifdef YYY
1456         CASE ( IO_YYY   )
1457           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_next_time( Hndl, DateStr, Status )
1458           IF ( .NOT. multi_files(io_form) ) THEN
1459             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1460             len_of_str = LEN(DateStr)
1461             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1462           ENDIF
1463 #endif
1464 #ifdef ZZZ
1465         CASE ( IO_ZZZ   )
1466           CALL ext_zzz_get_next_time( Hndl, DateStr, Status )
1467 #endif
1468 #ifdef GRIB1
1469         CASE ( IO_GRIB1   )
1470           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_next_time( Hndl, DateStr, Status )
1471           IF ( .NOT. multi_files(io_form) ) THEN
1472             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1473             len_of_str = LEN(DateStr)
1474             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1475           ENDIF
1476 #endif
1477 #ifdef GRIB2
1478         CASE ( IO_GRIB2   )
1479           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_next_time( Hndl, DateStr, Status )
1480           IF ( .NOT. multi_files(io_form) ) THEN
1481             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1482             len_of_str = LEN(DateStr)
1483             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1484           ENDIF
1485 #endif
1486 #ifdef INTIO
1487         CASE ( IO_INTIO   )
1488           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_get_next_time( Hndl, DateStr, Status )
1489           IF ( .NOT. multi_files(io_form) ) THEN
1490             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1491             len_of_str = LEN(DateStr)
1492             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1493           ENDIF
1494 #endif
1495         CASE DEFAULT
1496           Status = 0
1497       END SELECT
1498     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1499       CALL wrf_quilt_get_next_time( Hndl, DateStr, Status )
1500     ELSE
1501       Status = 0
1502     ENDIF
1503   ELSE
1504     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1505   ENDIF
1506   RETURN
1507 END SUBROUTINE wrf_get_next_time
1508
1509 !--- get_previous_time (not defined for IntIO )
1510
1511 SUBROUTINE wrf_get_previous_time ( DataHandle, DateStr, Status )
1512 !<DESCRIPTION>
1513 !<PRE>
1514 ! Returns the previous time stamp.
1515 !</PRE>
1516 !</DESCRIPTION>
1517   USE module_state_description
1518   IMPLICIT NONE
1519   INTEGER ,       INTENT(IN)  :: DataHandle
1520   CHARACTER*(*) :: DateStr
1521   INTEGER ,       INTENT(OUT) :: Status
1522 #include "wrf_status_codes.h"
1523
1524   INTEGER, EXTERNAL           :: use_package
1525   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1526   INTEGER                     :: io_form, len_of_str
1527   LOGICAL                     :: for_out
1528   INTEGER                     :: Hndl
1529
1530   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_previous_time' )
1531
1532   Status = 0
1533   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1534   IF ( Hndl .GT. -1 ) THEN
1535     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1536       SELECT CASE ( use_package(io_form) )
1537 #ifdef NETCDF
1538         CASE ( IO_NETCDF   )
1539           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_previous_time( Hndl, DateStr, Status )
1540           IF ( .NOT. multi_files(io_form) ) THEN
1541             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1542             len_of_str = LEN(DateStr)
1543             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1544           ENDIF
1545 #endif
1546 #ifdef PNETCDF
1547         CASE ( IO_PNETCDF   )
1548           CALL ext_pnc_get_previous_time( Hndl, DateStr, Status )
1549 #endif
1550 #ifdef PIO
1551         CASE ( IO_PIO )
1552           CALL ext_pio_get_previous_time( Hndl, DateStr, Status )
1553 #endif
1554 #ifdef ADIOS2
1555         CASE ( IO_ADIOS2   )
1556           CALL ext_adios2_get_previous_time( Hndl, DateStr, Status )
1557 #endif
1558 #ifdef PHDF5
1559         CASE ( IO_PHDF5   )
1560           CALL ext_phdf5_get_previous_time( Hndl, DateStr, Status )
1561 #endif
1562 #ifdef NETCDFPAR
1563         CASE ( IO_NETCDFPAR   )
1564           CALL ext_ncdpar_get_previous_time( Hndl, DateStr, Status )
1565 #endif
1566 #ifdef XXX
1567         CASE ( IO_XXX   )
1568           CALL ext_xxx_get_previous_time( Hndl, DateStr, Status )
1569 #endif
1570 #ifdef YYY
1571         CASE ( IO_YYY   )
1572           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_previous_time( Hndl, DateStr, Status )
1573           IF ( .NOT. multi_files(io_form) ) THEN
1574             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1575             len_of_str = LEN(DateStr)
1576             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1577          ENDIF
1578 #endif
1579 #ifdef ZZZ
1580         CASE ( IO_ZZZ   )
1581           CALL ext_zzz_get_previous_time( Hndl, DateStr, Status )
1582 #endif
1583 #ifdef GRIB1
1584         CASE ( IO_GRIB1   )
1585           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_previous_time( Hndl, DateStr, Status )
1586           IF ( .NOT. multi_files(io_form) ) THEN
1587             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1588             len_of_str = LEN(DateStr)
1589             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1590          ENDIF
1591 #endif
1592 #ifdef GRIB2
1593         CASE ( IO_GRIB2   )
1594           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_previous_time( Hndl, DateStr, Status )
1595           IF ( .NOT. multi_files(io_form) ) THEN
1596             CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1597             len_of_str = LEN(DateStr)
1598             CALL wrf_dm_bcast_string ( DateStr , len_of_str )
1599          ENDIF
1600 #endif
1601 #ifdef INTIO
1602 #endif
1603         CASE DEFAULT
1604           Status = 0
1605       END SELECT
1606     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1607       CALL wrf_quilt_get_previous_time( Hndl, DateStr, Status )
1608     ELSE
1609       Status = 0
1610     ENDIF
1611   ELSE
1612     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1613   ENDIF
1614   RETURN
1615 END SUBROUTINE wrf_get_previous_time
1616
1617 !--- set_time
1618
1619 SUBROUTINE wrf_set_time ( DataHandle, DateStr, Status )
1620 !<DESCRIPTION>
1621 !<PRE>
1622 ! Sets the time stamp.
1623 !</PRE>
1624 !</DESCRIPTION>
1625   USE module_state_description
1626   IMPLICIT NONE
1627   INTEGER ,       INTENT(IN)  :: DataHandle
1628   CHARACTER*(*) :: DateStr
1629   INTEGER ,       INTENT(OUT) :: Status
1630 #include "wrf_status_codes.h"
1631
1632   INTEGER, EXTERNAL           :: use_package
1633   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1634   INTEGER                     :: io_form
1635   LOGICAL                     :: for_out
1636   INTEGER                     :: Hndl
1637
1638   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_set_time' )
1639
1640   Status = 0
1641   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1642   IF ( Hndl .GT. -1 ) THEN
1643     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1644       SELECT CASE ( use_package( io_form ) )
1645 #ifdef NETCDF
1646         CASE ( IO_NETCDF   )
1647           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_set_time( Hndl, DateStr, Status )
1648           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1649 #endif
1650 #ifdef PHDF5
1651         CASE ( IO_PHDF5  )
1652           CALL ext_phdf5_set_time( Hndl, DateStr, Status )
1653 #endif
1654 #ifdef NETCDFPAR
1655         CASE ( IO_NETCDFPAR  )
1656           CALL ext_ncdpar_set_time( Hndl, DateStr, Status )
1657 #endif
1658 #ifdef PNETCDF
1659         CASE ( IO_PNETCDF  )
1660           CALL ext_pnc_set_time( Hndl, DateStr, Status )
1661 #endif
1662 #ifdef PIO
1663         CASE ( IO_PIO )
1664           CALL ext_pio_set_time( Hndl, DateStr, Status )
1665 #endif
1666 #ifdef ADIOS2
1667         CASE ( IO_ADIOS2  )
1668           CALL ext_adios2_set_time( Hndl, DateStr, Status )
1669 #endif
1670 #ifdef XXX
1671         CASE ( IO_XXX   )
1672           CALL ext_xxx_set_time( Hndl, DateStr, Status )
1673 #endif
1674 #ifdef YYY
1675         CASE ( IO_YYY   )
1676           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_set_time( Hndl, DateStr, Status )
1677           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1678 #endif
1679 #ifdef ZZZ
1680         CASE ( IO_ZZZ   )
1681           CALL ext_zzz_set_time( Hndl, DateStr, Status )
1682 #endif
1683 #ifdef GRIB1
1684         CASE ( IO_GRIB1   )
1685           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_set_time( Hndl, DateStr, Status )
1686           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1687 #endif
1688 #ifdef GRIB2
1689         CASE ( IO_GRIB2   )
1690           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_set_time( Hndl, DateStr, Status )
1691           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1692 #endif
1693 #ifdef INTIO
1694         CASE ( IO_INTIO   )
1695           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_set_time( Hndl, DateStr, Status )
1696           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1697 #endif
1698         CASE DEFAULT
1699           Status = 0
1700       END SELECT
1701     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1702       CALL wrf_quilt_set_time( Hndl, DateStr, Status )
1703     ELSE
1704       Status = 0
1705     ENDIF
1706   ELSE
1707     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1708   ENDIF
1709   RETURN
1710 END SUBROUTINE wrf_set_time
1711
1712 !--- get_next_var  (not defined for IntIO)
1713
1714 SUBROUTINE wrf_get_next_var ( DataHandle, VarName, Status )
1715 !<DESCRIPTION>
1716 !<PRE>
1717 ! On reading, this routine returns the name of the next variable in the
1718 ! current time frame.
1719 !</PRE>
1720 !</DESCRIPTION>
1721   USE module_state_description
1722   IMPLICIT NONE
1723   INTEGER ,       INTENT(IN)  :: DataHandle
1724   CHARACTER*(*) :: VarName
1725   INTEGER ,       INTENT(OUT) :: Status
1726 #include "wrf_status_codes.h"
1727
1728   INTEGER, EXTERNAL           :: use_package
1729   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1730   INTEGER                     :: io_form
1731   LOGICAL                     :: for_out
1732   INTEGER                     :: Hndl
1733
1734   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_next_var' )
1735
1736   Status = 0
1737   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1738   IF ( Hndl .GT. -1 ) THEN
1739     IF ( multi_files( io_form ) .OR. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1740       SELECT CASE ( use_package( io_form ) )
1741 #ifdef NETCDF
1742         CASE ( IO_NETCDF   )
1743           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_ncd_get_next_var( Hndl, VarName, Status )
1744           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1745 #endif
1746 #ifdef XXX
1747         CASE ( IO_XXX   )
1748           CALL ext_xxx_get_next_var( Hndl, VarName, Status )
1749 #endif
1750 #ifdef YYY
1751         CASE ( IO_YYY   )
1752           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_yyy_get_next_var( Hndl, VarName, Status )
1753           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1754 #endif
1755 #ifdef ZZZ
1756         CASE ( IO_ZZZ   )
1757           CALL ext_zzz_get_next_var( Hndl, VarName, Status )
1758 #endif
1759 #ifdef GRIB1
1760         CASE ( IO_GRIB1   )
1761           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr1_get_next_var( Hndl, VarName, Status )
1762           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1763 #endif
1764 #ifdef GRIB2
1765         CASE ( IO_GRIB2   )
1766           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_gr2_get_next_var( Hndl, VarName, Status )
1767           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1768 #endif
1769 #ifdef INTIO
1770         CASE ( IO_INTIO   )
1771           IF ( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) CALL ext_int_get_next_var( Hndl, VarName, Status )
1772           CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
1773 #endif
1774         CASE DEFAULT
1775           Status = 0
1776       END SELECT
1777     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1778       CALL wrf_quilt_get_next_var( Hndl, VarName, Status )
1779     ELSE
1780       Status = 0
1781     ENDIF
1782   ELSE
1783     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1784   ENDIF
1785   RETURN
1786 END SUBROUTINE wrf_get_next_var
1787
1788
1789 ! wrf_get_var_info  (not implemented for IntIO)
1790
1791 SUBROUTINE wrf_get_var_info ( DataHandle , VarName , NDim , MemoryOrder , Stagger , &
1792                               DomainStart , DomainEnd , Status )
1793 !<DESCRIPTION>
1794 !<PRE>
1795 ! This routine applies only to a dataset that is open for read.  It returns
1796 ! information about a variable.
1797 !</PRE>
1798 !</DESCRIPTION>
1799   USE module_state_description
1800   IMPLICIT NONE
1801   INTEGER               ,INTENT(IN)     :: DataHandle
1802   CHARACTER*(*)         ,INTENT(IN)     :: VarName
1803   INTEGER               ,INTENT(OUT)    :: NDim
1804   CHARACTER*(*)         ,INTENT(OUT)    :: MemoryOrder
1805   CHARACTER*(*)         ,INTENT(OUT)    :: Stagger
1806   INTEGER ,dimension(*) ,INTENT(OUT)    :: DomainStart, DomainEnd
1807   INTEGER               ,INTENT(OUT)    :: Status
1808 #include "wrf_status_codes.h"
1809   INTEGER                     :: io_form
1810   LOGICAL                     :: for_out
1811   INTEGER, EXTERNAL           :: use_package
1812   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers_for
1813   INTEGER                     :: Hndl
1814
1815   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_get_var_info' )
1816
1817   Status = 0
1818   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
1819   IF ( Hndl .GT. -1 ) THEN
1820     IF (( multi_files(io_form) .OR.  wrf_dm_on_monitor() ) .AND. .NOT. (for_out .AND. use_output_servers_for(io_form)) ) THEN
1821       SELECT CASE ( use_package( io_form ) )
1822 #ifdef NETCDF
1823         CASE ( IO_NETCDF   )
1824           CALL ext_ncd_get_var_info ( Hndl , VarName , NDim ,            &
1825                                       MemoryOrder , Stagger ,                  &
1826                                       DomainStart , DomainEnd ,                &
1827                                       Status )
1828 #endif
1829 #ifdef PHDF5
1830         CASE ( IO_PHDF5)
1831           CALL ext_phdf5_get_var_info ( Hndl , VarName , NDim ,            &
1832                                       MemoryOrder , Stagger ,                  &
1833                                       DomainStart , DomainEnd ,                &
1834                                       Status )
1835 #endif
1836 #ifdef NETCDFPAR
1837         CASE ( IO_NETCDFPAR)
1838           CALL ext_ncdpar_get_var_info ( Hndl , VarName , NDim ,            &
1839                                       MemoryOrder , Stagger ,                  &
1840                                       DomainStart , DomainEnd ,                &
1841                                       Status )
1842 #endif
1843 #ifdef PNETCDF
1844         CASE ( IO_PNETCDF)
1845           CALL ext_pnc_get_var_info ( Hndl , VarName , NDim ,            &
1846                                       MemoryOrder , Stagger ,                  &
1847                                       DomainStart , DomainEnd ,                &
1848                                       Status )
1849 #endif
1850 #ifdef PIO
1851         CASE ( IO_PIO )
1852           CALL ext_pio_get_var_info ( Hndl , VarName , NDim ,                  &
1853                                       MemoryOrder , Stagger ,                  &
1854                                       DomainStart , DomainEnd ,                &
1855                                       Status )
1856 #endif
1857 #ifdef ADIOS2
1858         CASE ( IO_ADIOS2)
1859           CALL ext_adios2_get_var_info ( Hndl , VarName , NDim ,            &
1860                                       MemoryOrder , Stagger ,                  &
1861                                       DomainStart , DomainEnd ,                &
1862                                       Status )
1863 #endif
1864 #ifdef XXX
1865         CASE ( IO_XXX )
1866           CALL ext_xxx_get_var_info ( Hndl , VarName , NDim ,            &
1867                                       MemoryOrder , Stagger ,                  &
1868                                       DomainStart , DomainEnd ,                &
1869                                       Status )
1870 #endif
1871 #ifdef YYY
1872         CASE ( IO_YYY )
1873           CALL ext_yyy_get_var_info ( Hndl , VarName , NDim ,            &
1874                                       MemoryOrder , Stagger ,                  &
1875                                       DomainStart , DomainEnd ,                &
1876                                       Status )
1877 #endif
1878 #ifdef GRIB1
1879         CASE ( IO_GRIB1 )
1880           CALL ext_gr1_get_var_info ( Hndl , VarName , NDim ,            &
1881                                       MemoryOrder , Stagger ,                  &
1882                                       DomainStart , DomainEnd ,                &
1883                                       Status )
1884 #endif
1885 #ifdef GRIB2
1886         CASE ( IO_GRIB2 )
1887           CALL ext_gr2_get_var_info ( Hndl , VarName , NDim ,            &
1888                                       MemoryOrder , Stagger ,                  &
1889                                       DomainStart , DomainEnd ,                &
1890                                       Status )
1891 #endif
1892         CASE DEFAULT
1893           Status = 0
1894       END SELECT
1895     ELSE IF ( io_form .GT. 0 .AND. for_out .AND. use_output_servers_for(io_form) ) THEN
1896       CALL wrf_quilt_get_var_info ( Hndl , VarName , NDim ,            &
1897                                     MemoryOrder , Stagger ,                  &
1898                                     DomainStart , DomainEnd ,                &
1899                                     Status )
1900     ELSE
1901       Status = 0
1902     ENDIF
1903   ELSE
1904     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
1905   ENDIF
1906   RETURN
1907
1908 END SUBROUTINE wrf_get_var_info
1909
1910
1911
1912 !---------------------------------------------------------------------------------
1913
1914
1915 SUBROUTINE init_io_handles()
1916 !<DESCRIPTION>
1917 !<PRE>
1918 ! Initialize all I/O handles.
1919 !</PRE>
1920 !</DESCRIPTION>
1921   IMPLICIT NONE
1922   INTEGER i
1923   IF ( .NOT. is_inited ) THEN
1924     DO i = 1, MAX_WRF_IO_HANDLE
1925       wrf_io_handles(i) = -999319
1926     ENDDO
1927     is_inited = .TRUE.
1928   ENDIF
1929   RETURN
1930 END SUBROUTINE init_io_handles
1931
1932 SUBROUTINE add_new_handle( Hndl, Hopened, for_out, DataHandle )
1933 !<DESCRIPTION>
1934 !<PRE>
1935 ! Stash the package-specific I/O handle (Hndl) and return a WRF I/O handle
1936 ! (DataHandle).
1937 ! File format ID is passed in via Hopened.
1938 ! for_out will be .TRUE. if this routine was called from an
1939 ! open-for-read/write-begin operation and .FALSE. otherwise.
1940 !</PRE>
1941 !</DESCRIPTION>
1942   IMPLICIT NONE
1943   INTEGER, INTENT(IN)     :: Hndl
1944   INTEGER, INTENT(IN)     :: Hopened
1945   LOGICAL, INTENT(IN)     :: for_out
1946   INTEGER, INTENT(OUT)    :: DataHandle
1947   INTEGER i
1948   INTEGER, EXTERNAL       :: use_package
1949   LOGICAL, EXTERNAL       :: multi_files
1950   IF ( .NOT. is_inited ) THEN
1951     CALL wrf_error_fatal( 'add_new_handle: not initialized' )
1952   ENDIF
1953   IF ( multi_files( Hopened ) ) THEN
1954     SELECT CASE ( use_package( Hopened ) )
1955 #ifdef PHDF5
1956       CASE ( IO_PHDF5  )
1957         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for PHDF5' )
1958 #endif
1959 #ifdef NETCDFPAR
1960       CASE ( IO_NETCDFPAR  )
1961         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for NETCDFPAR' )
1962 #endif
1963 #ifdef PNETCDF
1964       CASE ( IO_PNETCDF  )
1965         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for PNETCDF' )
1966 #endif
1967 #ifdef PIO
1968       CASE ( IO_PIO )
1969         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for PIO' )
1970 #endif
1971 #ifdef ADIOS2
1972       CASE ( IO_ADIOS2  )
1973         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for ADIOS2' )
1974 #endif
1975 #ifdef ESMFIO
1976       CASE ( IO_ESMF )
1977         CALL wrf_error_fatal( 'add_new_handle:  multiple output files not supported for ESMF' )
1978 #endif
1979     END SELECT
1980   ENDIF
1981   DataHandle = -1
1982   DO i = 1, MAX_WRF_IO_HANDLE
1983     IF ( wrf_io_handles(i) .EQ. -999319 ) THEN
1984       DataHandle = i
1985       wrf_io_handles(i) = Hndl
1986       how_opened(i)     = Hopened
1987       for_output(DataHandle) = for_out
1988       first_operation(DataHandle) = .TRUE.
1989       EXIT
1990     ENDIF
1991   ENDDO
1992   IF ( DataHandle .EQ. -1 ) THEN
1993     CALL wrf_error_fatal( 'add_new_handle: no handles left' )
1994   ENDIF
1995   RETURN
1996 END SUBROUTINE add_new_handle
1997
1998 SUBROUTINE get_handle ( Hndl, Hopened, for_out, DataHandle )
1999 !<DESCRIPTION>
2000 !<PRE>
2001 ! Return the package-specific handle (Hndl) from a WRF handle
2002 ! (DataHandle).
2003 ! Return file format ID via Hopened.
2004 ! Also, for_out will be set to .TRUE. if the file was opened
2005 ! with an open-for-read/write-begin operation and .FALSE.
2006 ! otherwise.
2007 !</PRE>
2008 !</DESCRIPTION>
2009   IMPLICIT NONE
2010   INTEGER, INTENT(OUT)     :: Hndl
2011   INTEGER, INTENT(OUT)     :: Hopened
2012   LOGICAL, INTENT(OUT)     :: for_out
2013   INTEGER, INTENT(IN)    :: DataHandle
2014   CHARACTER*128 mess
2015   INTEGER i
2016   IF ( .NOT. is_inited ) THEN
2017     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
2018   ENDIF
2019   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
2020     Hndl = wrf_io_handles(DataHandle)
2021     Hopened = how_opened(DataHandle)
2022     for_out = for_output(DataHandle)
2023   ELSE
2024     Hndl = -1
2025   ENDIF
2026   RETURN
2027 END SUBROUTINE get_handle
2028
2029 SUBROUTINE set_first_operation( DataHandle )
2030 !<DESCRIPTION>
2031 !<PRE>
2032 ! Sets internal flag to indicate that the first read or write has not yet
2033 ! happened for the dataset referenced by DataHandle.
2034 !</PRE>
2035 !</DESCRIPTION>
2036   IMPLICIT NONE
2037   INTEGER, INTENT(IN)    :: DataHandle
2038   IF ( .NOT. is_inited ) THEN
2039     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
2040   ENDIF
2041   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
2042     first_operation(DataHandle) = .TRUE.
2043   ENDIF
2044   RETURN
2045 END SUBROUTINE set_first_operation
2046
2047 SUBROUTINE reset_first_operation( DataHandle )
2048 !<DESCRIPTION>
2049 !<PRE>
2050 ! Resets internal flag to indicate that the first read or write has already
2051 ! happened for the dataset referenced by DataHandle.
2052 !</PRE>
2053 !</DESCRIPTION>
2054   IMPLICIT NONE
2055   INTEGER, INTENT(IN)    :: DataHandle
2056   IF ( .NOT. is_inited ) THEN
2057     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
2058   ENDIF
2059   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
2060     first_operation(DataHandle) = .FALSE.
2061   ENDIF
2062   RETURN
2063 END SUBROUTINE reset_first_operation
2064
2065 LOGICAL FUNCTION is_first_operation( DataHandle )
2066 !<DESCRIPTION>
2067 !<PRE>
2068 ! Returns .TRUE. the first read or write has not yet happened for the dataset
2069 ! referenced by DataHandle.
2070 !</PRE>
2071 !</DESCRIPTION>
2072   IMPLICIT NONE
2073   INTEGER, INTENT(IN)    :: DataHandle
2074   IF ( .NOT. is_inited ) THEN
2075     CALL wrf_error_fatal( 'module_io.F: get_handle: not initialized' )
2076   ENDIF
2077   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
2078     is_first_operation = first_operation(DataHandle)
2079   ENDIF
2080   RETURN
2081 END FUNCTION is_first_operation
2082
2083 SUBROUTINE free_handle ( DataHandle )
2084 !<DESCRIPTION>
2085 !<PRE>
2086 ! Trash a handle and return to "unused" pool.
2087 !</PRE>
2088 !</DESCRIPTION>
2089   IMPLICIT NONE
2090   INTEGER, INTENT(IN)    :: DataHandle
2091   INTEGER i
2092   IF ( .NOT. is_inited ) THEN
2093     CALL wrf_error_fatal( 'free_handle: not initialized' )
2094   ENDIF
2095   IF ( DataHandle .GE. 1 .AND. DataHandle .LE. MAX_WRF_IO_HANDLE ) THEN
2096     wrf_io_handles(DataHandle) = -999319
2097   ENDIF
2098   RETURN
2099 END SUBROUTINE free_handle
2100
2101 !--------------------------------------------------------------
2102
2103 SUBROUTINE init_module_io
2104 !<DESCRIPTION>
2105 !<PRE>
2106 ! Initialize this module.  Must be called before any other operations are
2107 ! attempted.
2108 !</PRE>
2109 !</DESCRIPTION>
2110   CALL init_io_handles
2111 END SUBROUTINE init_module_io
2112
2113 SUBROUTINE are_bdys_distributed( res )
2114   IMPLICIT NONE
2115   LOGICAL, INTENT(OUT) :: res
2116   res = bdy_dist_flag
2117 END SUBROUTINE are_bdys_distributed
2118
2119 SUBROUTINE bdys_not_distributed
2120   IMPLICIT NONE
2121   bdy_dist_flag = .FALSE.
2122 END SUBROUTINE bdys_not_distributed
2123
2124 SUBROUTINE bdys_are_distributed
2125   IMPLICIT NONE
2126   bdy_dist_flag = .TRUE.
2127 END SUBROUTINE bdys_are_distributed
2128
2129 LOGICAL FUNCTION on_stream ( mask , switch )
2130   IMPLICIT NONE
2131   INTEGER, INTENT(IN) :: mask(*), switch
2132   INTEGER             :: result
2133 ! get_mask is a C routine defined in frame/pack_utils.c
2134 ! switch is decremented from its fortran value so it is zero based
2135   CALL get_mask( mask, switch-1, result )
2136   on_stream = ( result .NE. 0 )
2137 END FUNCTION on_stream
2138
2139 SUBROUTINE wrf_start_io_timestep (DataHandle, Status)
2140 !<DESCRIPTION>
2141 !<PRE>
2142 ! Signals to I/O library that an I/O time step is starting, and allows the
2143 ! I/O library to partition events into separate logical time steps.
2144 !</PRE>
2145 !</DESCRIPTION>
2146   IMPLICIT NONE
2147   INTEGER, INTENT(IN)    :: DataHandle
2148   INTEGER, INTENT(OUT)   :: Status
2149   INTEGER                :: Hndl
2150   INTEGER                :: io_form
2151   LOGICAL                :: for_out
2152   INTEGER, EXTERNAL      :: use_package
2153 #include "wrf_status_codes.h"
2154   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
2155   SELECT CASE ( use_package( io_form ) )
2156 #ifdef ADIOS2
2157     CASE ( IO_ADIOS2 )
2158       CALL ext_adios2_start_io_timestep(Hndl, Status)
2159 #endif
2160     CASE DEFAULT
2161       Status = 0
2162   END SELECT
2163 END SUBROUTINE
2164
2165 SUBROUTINE wrf_end_io_timestep (DataHandle, Status)
2166 !<DESCRIPTION>
2167 !<PRE>
2168 ! Signals to I/O library that an I/O time step is ending, and allows the
2169 ! I/O library to partition events into separate logical time steps.
2170 !</PRE>
2171 !</DESCRIPTION>
2172   IMPLICIT NONE
2173   INTEGER, INTENT(IN)    :: DataHandle
2174   INTEGER, INTENT(OUT)   :: Status
2175   INTEGER                :: Hndl
2176   INTEGER                :: io_form
2177   LOGICAL                :: for_out
2178   INTEGER, EXTERNAL      :: use_package
2179 #include "wrf_status_codes.h"
2180   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
2181   SELECT CASE ( use_package( io_form ) )
2182 #ifdef ADIOS2
2183     CASE ( IO_ADIOS2 )
2184       CALL ext_adios2_end_io_timestep(Hndl, Status)
2185 #endif
2186     CASE DEFAULT
2187       Status = 0
2188   END SELECT
2189 END SUBROUTINE
2190
2191 END MODULE module_io
2192
2193
2194 !<DESCRIPTION>
2195 !<PRE>
2196 ! Remaining routines in this file are defined outside of the module to
2197 ! defeat arg/param type checking.
2198 !</PRE>
2199 !</DESCRIPTION>
2200 SUBROUTINE wrf_read_field ( DataHandle , DateStr , VarName , Field , FieldType ,         &
2201                             grid ,                                                       &
2202                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
2203                             DomainStart , DomainEnd ,                                    &
2204                             MemoryStart , MemoryEnd ,                                    &
2205                             PatchStart , PatchEnd ,                                      &
2206                             Status )
2207 !<DESCRIPTION>
2208 !<PRE>
2209 ! Read the variable named VarName from the dataset pointed to by DataHandle.
2210 ! This routine is a wrapper that ensures uniform treatment of logicals across
2211 ! platforms by reading as integer and then converting to logical.
2212 !</PRE>
2213 !</DESCRIPTION>
2214   USE module_state_description
2215   USE module_configure
2216   USE module_domain
2217   IMPLICIT NONE
2218   INTEGER ,       INTENT(IN)    :: DataHandle
2219   CHARACTER*(*) :: DateStr
2220   CHARACTER*(*) :: VarName
2221   LOGICAL ,       INTENT(INOUT) :: Field(*)
2222   INTEGER                       ,INTENT(IN)    :: FieldType
2223   TYPE(domain)                                 :: grid
2224   INTEGER                       ,INTENT(IN)    :: DomainDesc
2225   LOGICAL, DIMENSION(4)                        :: bdy_mask
2226   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
2227   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
2228   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
2229   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
2230   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
2231   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
2232   INTEGER                       ,INTENT(OUT)   :: Status
2233 #include "wrf_status_codes.h"
2234 #include "wrf_io_flags.h"
2235   INTEGER, ALLOCATABLE        :: ICAST(:)
2236   LOGICAL perturb_input
2237   IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2238     ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
2239
2240     CALL wrf_read_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER ,       &
2241                            grid ,                                                       &
2242                            DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
2243                            DomainStart , DomainEnd ,                                    &
2244                            MemoryStart , MemoryEnd ,                                    &
2245                            PatchStart , PatchEnd ,                                      &
2246                            Status )
2247     Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) = ICAST == 1
2248     DEALLOCATE(ICAST)
2249   ELSE
2250     CALL wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
2251                            grid ,                                                       &
2252                            DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
2253                            DomainStart , DomainEnd ,                                    &
2254                            MemoryStart , MemoryEnd ,                                    &
2255                            PatchStart , PatchEnd ,                                      &
2256                            Status )
2257     CALL nl_get_perturb_input( 1, perturb_input )
2258     IF ( perturb_input .AND. FieldType .EQ. WRF_FLOAT .AND. TRIM(MemoryOrder) .EQ. 'XZY' ) THEN
2259        CALL perturb_real ( Field, DomainStart, DomainEnd,        &
2260                                   MemoryStart, MemoryEnd,        &
2261                                   PatchStart, PatchEnd )
2262     ENDIF
2263   ENDIF
2264 END SUBROUTINE wrf_read_field
2265
2266 SUBROUTINE wrf_read_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,        &
2267                             grid ,                                                       &
2268                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
2269                             DomainStart , DomainEnd ,                                    &
2270                             MemoryStart , MemoryEnd ,                                    &
2271                             PatchStart , PatchEnd ,                                      &
2272                             Status )
2273 !<DESCRIPTION>
2274 !<PRE>
2275 ! Read the variable named VarName from the dataset pointed to by DataHandle.
2276 ! Calls ext_pkg_read_field() via call_pkg_and_dist().
2277 !</PRE>
2278 !</DESCRIPTION>
2279   USE module_state_description
2280   USE module_configure
2281   USE module_io
2282   USE module_domain
2283   IMPLICIT NONE
2284   INTEGER ,       INTENT(IN)    :: DataHandle
2285   CHARACTER*(*) :: DateStr
2286   CHARACTER*(*) :: VarName
2287   INTEGER ,       INTENT(INOUT) :: Field(*)
2288   INTEGER                       ,INTENT(IN)    :: FieldType
2289   TYPE(domain)                                 :: grid
2290   INTEGER                       ,INTENT(IN)    :: DomainDesc
2291   LOGICAL, DIMENSION(4)                        :: bdy_mask
2292   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
2293   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
2294   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
2295   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
2296   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
2297   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
2298   INTEGER                       ,INTENT(OUT)   :: Status
2299 #include "wrf_status_codes.h"
2300   INTEGER                     :: io_form
2301   LOGICAL                     :: for_out
2302   INTEGER, EXTERNAL           :: use_package
2303   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers, use_input_servers, use_output_servers_for
2304 #ifdef NETCDF
2305   EXTERNAL     ext_ncd_read_field
2306 #endif
2307 #ifdef NETCDFPAR
2308   EXTERNAL     ext_ncdpar_read_field
2309 #endif
2310 #ifdef PNETCDF
2311   EXTERNAL     ext_pnc_read_field
2312 #endif
2313 #ifdef PIO
2314   EXTERNAL     ext_pio_read_field
2315 #endif
2316 #ifdef ADIOS2
2317   EXTERNAL     ext_adios2_read_field
2318 #endif
2319 #ifdef ESMFIO
2320   EXTERNAL     ext_esmf_read_field
2321 #endif
2322 #ifdef INTIO
2323   EXTERNAL     ext_int_read_field
2324 #endif
2325 #ifdef XXX
2326   EXTERNAL ext_xxx_read_field
2327 #endif
2328 #ifdef YYY
2329   EXTERNAL ext_yyy_read_field
2330 #endif
2331 #ifdef GRIB1
2332   EXTERNAL ext_gr1_read_field
2333 #endif
2334 #ifdef GRIB2
2335   EXTERNAL ext_gr2_read_field
2336 #endif
2337
2338   INTEGER                     :: Hndl
2339   INTEGER                     :: Comm
2340   INTEGER                     :: IOComm
2341
2342   Comm = grid%communicator
2343   IOComm = grid%iocommunicator
2344
2345   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_read_field' )
2346
2347   Status = 0
2348   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
2349   CALL reset_first_operation( DataHandle )
2350   IF ( Hndl .GT. -1 ) THEN
2351     IF ( .NOT. io_form .GT. 0 ) THEN
2352       Status = 0
2353     ELSE IF ( .NOT. use_input_servers() ) THEN
2354       SELECT CASE ( use_package( io_form ) )
2355 #ifdef NETCDF
2356         CASE ( IO_NETCDF   )
2357
2358           CALL call_pkg_and_dist   ( ext_ncd_read_field, multi_files(io_form), .false. ,        &
2359                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2360                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2361                                      DomainStart , DomainEnd ,                                    &
2362                                      MemoryStart , MemoryEnd ,                                    &
2363                                      PatchStart , PatchEnd ,                                      &
2364                                      Status )
2365
2366 #endif
2367 #ifdef PHDF5
2368         CASE ( IO_PHDF5)
2369           CALL ext_phdf5_read_field   (                   &
2370                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2371                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2372                                      DomainStart , DomainEnd ,                                    &
2373                                      MemoryStart , MemoryEnd ,                                    &
2374                                      PatchStart , PatchEnd ,                                      &
2375                                      Status )
2376 #endif
2377 #ifdef NETCDFPAR
2378         CASE ( IO_NETCDFPAR )
2379           CALL ext_ncdpar_read_field   (                   &
2380                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2381                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2382                                      DomainStart , DomainEnd ,                                    &
2383                                      MemoryStart , MemoryEnd ,                                    &
2384                                      PatchStart , PatchEnd ,                                      &
2385                                      Status )
2386 #endif
2387 #ifdef PNETCDF
2388         CASE ( IO_PNETCDF)
2389           CALL ext_pnc_read_field   (                   &
2390                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2391                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2392                                      DomainStart , DomainEnd ,                                    &
2393                                      MemoryStart , MemoryEnd ,                                    &
2394                                      PatchStart , PatchEnd ,                                      &
2395                                      Status )
2396 #endif
2397 #ifdef PIO
2398         CASE ( IO_PIO)
2399           CALL ext_pio_read_field(Hndl , DateStr , VarName , Field , FieldType , grid , &
2400                                   DomainDesc , MemoryOrder , Stagger , DimNames ,       &
2401                                   DomainStart , DomainEnd ,                             &
2402                                   MemoryStart , MemoryEnd ,                             &
2403                                   PatchStart , PatchEnd ,                               &
2404                                   Status)
2405 #endif
2406 #ifdef ADIOS2
2407         CASE ( IO_ADIOS2)
2408           CALL ext_adios2_read_field   (                   &
2409                                      Hndl , DateStr , VarName , Field , FieldType , &
2410                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2411                                      DomainStart , DomainEnd ,                                    &
2412                                      MemoryStart , MemoryEnd ,                                    &
2413                                      PatchStart , PatchEnd ,                                      &
2414                                      Status )
2415 #endif
2416 #ifdef ESMFIO
2417         CASE ( IO_ESMF )
2418           CALL ext_esmf_read_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2419                                     DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2420                                     DomainStart , DomainEnd ,                                    &
2421                                     MemoryStart , MemoryEnd ,                                    &
2422                                     PatchStart , PatchEnd ,                                      &
2423                                     Status )
2424 #endif
2425 #ifdef XXX
2426         CASE ( IO_XXX )
2427           CALL call_pkg_and_dist   ( ext_xxx_read_field, multi_files(io_form), .false.,         &
2428                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2429                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2430                                      DomainStart , DomainEnd ,                                    &
2431                                      MemoryStart , MemoryEnd ,                                    &
2432                                      PatchStart , PatchEnd ,                                      &
2433                                      Status )
2434 #endif
2435 #ifdef YYY
2436         CASE ( IO_YYY )
2437           CALL call_pkg_and_dist   ( ext_yyy_read_field, multi_files(io_form), .false.,         &
2438                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2439                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2440                                      DomainStart , DomainEnd ,                                    &
2441                                      MemoryStart , MemoryEnd ,                                    &
2442                                      PatchStart , PatchEnd ,                                      &
2443                                      Status )
2444 #endif
2445 #ifdef INTIO
2446         CASE ( IO_INTIO )
2447           CALL call_pkg_and_dist   ( ext_int_read_field, multi_files(io_form), .false.,         &
2448                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2449                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2450                                      DomainStart , DomainEnd ,                                    &
2451                                      MemoryStart , MemoryEnd ,                                    &
2452                                      PatchStart , PatchEnd ,                                      &
2453                                      Status )
2454 #endif
2455 #ifdef GRIB1
2456         CASE ( IO_GRIB1 )
2457           CALL call_pkg_and_dist   ( ext_gr1_read_field, multi_files(io_form), .false.,         &
2458                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2459                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2460                                      DomainStart , DomainEnd ,                                    &
2461                                      MemoryStart , MemoryEnd ,                                    &
2462                                      PatchStart , PatchEnd ,                                      &
2463                                      Status )
2464 #endif
2465 #ifdef GRIB2
2466         CASE ( IO_GRIB2 )
2467           CALL call_pkg_and_dist   ( ext_gr2_read_field, multi_files(io_form), .false.,         &
2468                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2469                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2470                                      DomainStart , DomainEnd ,                                    &
2471                                      MemoryStart , MemoryEnd ,                                    &
2472                                      PatchStart , PatchEnd ,                                      &
2473                                      Status )
2474 #endif
2475         CASE DEFAULT
2476           Status = 0
2477       END SELECT
2478     ELSE
2479       CALL wrf_error_fatal('module_io.F: wrf_read_field: input_servers not implemented yet')
2480     ENDIF
2481   ELSE
2482     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2483   ENDIF
2484   RETURN
2485 END SUBROUTINE wrf_read_field1
2486
2487 SUBROUTINE wrf_write_field ( DataHandle , DateStr , VarName , Field , FieldType ,         &
2488                              grid ,                                                       &
2489                              DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2490                              DomainStart , DomainEnd ,                                    &
2491                              MemoryStart , MemoryEnd ,                                    &
2492                              PatchStart , PatchEnd ,                                      &
2493                              Status )
2494 !<DESCRIPTION>
2495 !<PRE>
2496 ! Write the variable named VarName to the dataset pointed to by DataHandle.
2497 ! This routine is a wrapper that ensures uniform treatment of logicals across
2498 ! platforms by converting to integer before writing.
2499 !</PRE>
2500 !</DESCRIPTION>
2501   USE module_state_description
2502   USE module_configure
2503   USE module_domain
2504   IMPLICIT NONE
2505   INTEGER ,       INTENT(IN)    :: DataHandle
2506   CHARACTER*(*) :: DateStr
2507   CHARACTER*(*) :: VarName
2508   LOGICAL ,       INTENT(IN)    :: Field(*)
2509   INTEGER                       ,INTENT(IN)    :: FieldType
2510   TYPE(domain)                                 :: grid
2511   INTEGER                       ,INTENT(IN)    :: DomainDesc
2512   LOGICAL, DIMENSION(4)         ,INTENT(IN)    :: bdy_mask
2513   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
2514   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
2515   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
2516   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
2517   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
2518   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
2519   INTEGER                       ,INTENT(OUT)   :: Status
2520 #include "wrf_status_codes.h"
2521 #include "wrf_io_flags.h"
2522   INTEGER, ALLOCATABLE        :: ICAST(:)
2523   IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2524       ALLOCATE(ICAST((MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)))
2525       ICAST = 0
2526       WHERE ( Field(1:(MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)) )
2527         ICAST = 1
2528       END WHERE
2529     CALL wrf_write_field1 ( DataHandle , DateStr , VarName , ICAST , WRF_INTEGER ,         &
2530                             grid ,                                                       &
2531                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2532                             DomainStart , DomainEnd ,                                    &
2533                             MemoryStart , MemoryEnd ,                                    &
2534                             PatchStart , PatchEnd ,                                      &
2535                             Status )
2536       DEALLOCATE(ICAST)
2537   ELSE
2538     CALL wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
2539                             grid ,                                                       &
2540                             DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2541                             DomainStart , DomainEnd ,                                    &
2542                             MemoryStart , MemoryEnd ,                                    &
2543                             PatchStart , PatchEnd ,                                      &
2544                             Status )
2545   ENDIF
2546 END SUBROUTINE wrf_write_field
2547
2548 SUBROUTINE wrf_write_field1 ( DataHandle , DateStr , VarName , Field , FieldType ,         &
2549                              grid ,                                                        &
2550                              DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2551                              DomainStart , DomainEnd ,                                    &
2552                              MemoryStart , MemoryEnd ,                                    &
2553                              PatchStart , PatchEnd ,                                      &
2554                              Status )
2555 !<DESCRIPTION>
2556 !<PRE>
2557 ! Write the variable named VarName to the dataset pointed to by DataHandle.
2558 ! Calls ext_pkg_write_field() via collect_fld_and_call_pkg().
2559 !</PRE>
2560 !</DESCRIPTION>
2561
2562   USE module_state_description
2563   USE module_configure
2564   USE module_domain
2565   USE module_io
2566   IMPLICIT NONE
2567   INTEGER ,       INTENT(IN)    :: DataHandle
2568   CHARACTER*(*) :: DateStr
2569   CHARACTER*(*) :: VarName
2570   INTEGER ,       INTENT(IN)    :: Field(*)
2571   INTEGER                       ,INTENT(IN)    :: FieldType
2572   TYPE(domain)                                 :: grid
2573   INTEGER                       ,INTENT(IN)    :: DomainDesc
2574   LOGICAL, DIMENSION(4)         ,INTENT(IN)    :: bdy_mask
2575   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
2576   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
2577   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
2578   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
2579   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
2580   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
2581   INTEGER                       ,INTENT(OUT)   :: Status
2582 #include "wrf_status_codes.h"
2583   INTEGER, DIMENSION(3) :: starts, ends
2584   INTEGER               :: io_form
2585   CHARACTER*3 MemOrd
2586   LOGICAL                     :: for_out, okay_to_call
2587   INTEGER, EXTERNAL           :: use_package
2588   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor, multi_files, use_output_servers, use_output_servers_for
2589 #ifdef NETCDF
2590   EXTERNAL     ext_ncd_write_field
2591 #endif
2592 #ifdef NETCDFPAR
2593   EXTERNAL     ext_ncdpar_write_field
2594 #endif
2595 #ifdef PNETCDF
2596   EXTERNAL     ext_pnc_write_field
2597 #endif
2598 #ifdef PIO
2599   EXTERNAL     ext_pio_write_field
2600 #endif
2601 #ifdef ADIOS2
2602   EXTERNAL     ext_adios2_write_field
2603 #endif
2604 #ifdef ESMFIO
2605   EXTERNAL     ext_esmf_write_field
2606 #endif
2607 #ifdef INTIO
2608   EXTERNAL     ext_int_write_field
2609 #endif
2610 #ifdef XXX
2611   EXTERNAL ext_xxx_write_field
2612 #endif
2613 #ifdef YYY
2614   EXTERNAL ext_yyy_write_field
2615 #endif
2616 #ifdef GRIB1
2617   EXTERNAL ext_gr1_write_field
2618 #endif
2619 #ifdef GRIB2
2620   EXTERNAL ext_gr2_write_field
2621 #endif
2622
2623   INTEGER                     :: Hndl
2624   INTEGER                     :: Comm
2625   INTEGER                     :: IOComm
2626
2627   Comm = grid%communicator
2628   IOComm = grid%iocommunicator
2629
2630   CALL wrf_debug( DEBUG_LVL, 'module_io.F: in wrf_write_field' )
2631
2632   Status = 0
2633   CALL get_handle ( Hndl, io_form , for_out, DataHandle )
2634   CALL reset_first_operation ( DataHandle )
2635   IF ( Hndl .GT. -1 ) THEN
2636     IF ( multi_files( io_form ) .OR. .NOT. use_output_servers_for(io_form) ) THEN
2637       SELECT CASE ( use_package( io_form ) )
2638 #ifdef NETCDF
2639         CASE ( IO_NETCDF   )
2640           CALL collect_fld_and_call_pkg ( ext_ncd_write_field, multi_files(io_form),                  &
2641                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2642                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2643                                      DomainStart , DomainEnd ,                                    &
2644                                      MemoryStart , MemoryEnd ,                                    &
2645                                      PatchStart , PatchEnd ,                                      &
2646                                      Status )
2647 #endif
2648 #ifdef ESMFIO
2649         CASE ( IO_ESMF )
2650           CALL ext_esmf_write_field( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2651                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2652                                      DomainStart , DomainEnd ,                                    &
2653                                      MemoryStart , MemoryEnd ,                                    &
2654                                      PatchStart , PatchEnd ,                                      &
2655                                      Status )
2656 #endif
2657 #ifdef PHDF5
2658         CASE ( IO_PHDF5 )
2659           CALL ext_phdf5_write_field(                  &
2660                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2661                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2662                                      DomainStart , DomainEnd ,                                    &
2663                                      MemoryStart , MemoryEnd ,                                    &
2664                                      PatchStart , PatchEnd ,                                      &
2665                                      Status )
2666 #endif
2667 #ifdef NETCDFPAR
2668         CASE ( IO_NETCDFPAR )
2669           CALL ext_ncdpar_write_field(                  &
2670                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2671                                      DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2672                                      DomainStart , DomainEnd ,                                    &
2673                                      MemoryStart , MemoryEnd ,                                    &
2674                                      PatchStart , PatchEnd ,                                      &
2675                                      Status )
2676 #endif
2677 #ifdef PNETCDF
2678         CASE ( IO_PNETCDF )
2679           CALL lower_case( MemoryOrder, MemOrd )
2680           okay_to_call = .TRUE.
2681           IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE.
2682           IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE.
2683           IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE.
2684           IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE.
2685           IF ( okay_to_call ) THEN
2686              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3)
2687           ELSE
2688              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1
2689           ENDIF
2690
2691                CALL ext_pnc_write_field(                  &
2692                                        Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2693                                        DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2694                                        DomainStart , DomainEnd ,                                    &
2695                                        MemoryStart , MemoryEnd ,                                    &
2696                                        starts , ends ,                                      &
2697                                        Status )
2698 #endif
2699 #ifdef ADIOS2
2700         CASE ( IO_ADIOS2 )
2701           CALL lower_case( MemoryOrder, MemOrd )
2702           okay_to_call = .TRUE.
2703           IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE.
2704           IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE.
2705           IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE.
2706           IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE.
2707           IF ( okay_to_call ) THEN
2708              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3)
2709           ELSE
2710              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1
2711           ENDIF
2712
2713                CALL ext_adios2_write_field(                  &
2714                                        Hndl , DateStr , VarName , Field , FieldType , &
2715                                        DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2716                                        DomainStart , DomainEnd ,                                    &
2717                                        MemoryStart , MemoryEnd ,                                    &
2718                                        starts , ends ,                                      &
2719                                        Status )
2720 #endif
2721 #ifdef PIO
2722         CASE ( IO_PIO )
2723           CALL lower_case( MemoryOrder, MemOrd )
2724           okay_to_call = .TRUE.
2725           IF ((TRIM(MemOrd).EQ.'xsz' .OR. TRIM(MemOrd).EQ.'xs').AND. .NOT. bdy_mask(P_XSB)) okay_to_call = .FALSE.
2726           IF ((TRIM(MemOrd).EQ.'xez' .OR. TRIM(MemOrd).EQ.'xe').AND. .NOT. bdy_mask(P_XEB)) okay_to_call = .FALSE.
2727           IF ((TRIM(MemOrd).EQ.'ysz' .OR. TRIM(MemOrd).EQ.'ys').AND. .NOT. bdy_mask(P_YSB)) okay_to_call = .FALSE.
2728           IF ((TRIM(MemOrd).EQ.'yez' .OR. TRIM(MemOrd).EQ.'ye').AND. .NOT. bdy_mask(P_YEB)) okay_to_call = .FALSE.
2729           IF ( okay_to_call ) THEN
2730              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchEnd(1:3)
2731           ELSE
2732              starts(1:3) = PatchStart(1:3) ; ends(1:3) = PatchStart(1:3)-1
2733           ENDIF
2734
2735           CALL ext_pio_write_field( Hndl , DateStr , VarName , Field , FieldType , grid , &
2736                                     DomainDesc , MemoryOrder , Stagger , DimNames ,       &
2737                                     DomainStart , DomainEnd ,                             &
2738                                     MemoryStart , MemoryEnd ,                             &
2739                                     starts , ends , Status )
2740 #endif
2741 #ifdef XXX
2742         CASE ( IO_XXX )
2743           CALL collect_fld_and_call_pkg ( ext_xxx_write_field, multi_files(io_form),                  &
2744                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2745                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2746                                      DomainStart , DomainEnd ,                                    &
2747                                      MemoryStart , MemoryEnd ,                                    &
2748                                      PatchStart , PatchEnd ,                                      &
2749                                      Status )
2750 #endif
2751 #ifdef YYY
2752         CASE ( IO_YYY )
2753           CALL collect_fld_and_call_pkg ( ext_yyy_write_field, multi_files(io_form),                  &
2754                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2755                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2756                                      DomainStart , DomainEnd ,                                    &
2757                                      MemoryStart , MemoryEnd ,                                    &
2758                                      PatchStart , PatchEnd ,                                      &
2759                                      Status )
2760 #endif
2761 #ifdef GRIB1
2762         CASE ( IO_GRIB1 )
2763           CALL collect_fld_and_call_pkg ( ext_gr1_write_field, multi_files(io_form),                  &
2764                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2765                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2766                                      DomainStart , DomainEnd ,                                    &
2767                                      MemoryStart , MemoryEnd ,                                    &
2768                                      PatchStart , PatchEnd ,                                      &
2769                                      Status )
2770 #endif
2771 #ifdef GRIB2
2772         CASE ( IO_GRIB2 )
2773           CALL collect_fld_and_call_pkg ( ext_gr2_write_field, multi_files(io_form),                  &
2774                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2775                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2776                                      DomainStart , DomainEnd ,                                    &
2777                                      MemoryStart , MemoryEnd ,                                    &
2778                                      PatchStart , PatchEnd ,                                      &
2779                                      Status )
2780 #endif
2781 #ifdef INTIO
2782         CASE ( IO_INTIO )
2783           CALL collect_fld_and_call_pkg ( ext_int_write_field, multi_files(io_form),                  &
2784                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2785                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2786                                      DomainStart , DomainEnd ,                                    &
2787                                      MemoryStart , MemoryEnd ,                                    &
2788                                      PatchStart , PatchEnd ,                                      &
2789                                      Status )
2790 #endif
2791         CASE DEFAULT
2792           Status = 0
2793       END SELECT
2794     ELSE IF ( use_output_servers_for(io_form) ) THEN
2795       IF ( io_form .GT. 0 ) THEN
2796       CALL wrf_quilt_write_field ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2797                                    DomainDesc , MemoryOrder , Stagger , DimNames ,              &
2798                                    DomainStart , DomainEnd ,                                    &
2799                                    MemoryStart , MemoryEnd ,                                    &
2800                                    PatchStart , PatchEnd ,                                      &
2801                                    Status )
2802       ENDIF
2803     ENDIF
2804   ELSE
2805     Status = WRF_ERR_FATAL_BAD_FILE_STATUS
2806   ENDIF
2807   RETURN
2808 END SUBROUTINE wrf_write_field1
2809
2810 SUBROUTINE get_value_from_pairs ( varname , str , retval )
2811 !<DESCRIPTION>
2812 !<PRE>
2813 ! parse comma separated list of VARIABLE=VALUE strings and return the
2814 ! value for the matching variable if such exists, otherwise return
2815 ! the empty string
2816 !</PRE>
2817 !</DESCRIPTION>
2818   IMPLICIT NONE
2819   CHARACTER*(*) ::    varname
2820   CHARACTER*(*) ::    str
2821   CHARACTER*(*) ::    retval
2822
2823   CHARACTER (256) varstr, tstr
2824   INTEGER i,j,n,varstrn
2825   LOGICAL nobreak, nobreakouter
2826
2827   varstr = TRIM(varname)//"="
2828   varstrn = len(TRIM(varstr))
2829   n = len(str)
2830   retval = ""
2831   i = 1
2832   nobreakouter = .TRUE.
2833   DO WHILE ( nobreakouter )
2834     j = 1
2835     nobreak = .TRUE.
2836     tstr = ""
2837 ! Potential for out of bounds array ref on str(i:i) for i > n; reported by jedwards
2838 !    DO WHILE ( nobreak )
2839 !      IF ( str(i:i) .NE. ',' .AND. i .LE. n ) THEN
2840 !        tstr(j:j) = str(i:i)
2841 !      ELSE
2842 !        nobreak = .FALSE.
2843 !      ENDIF
2844 !      j = j + 1
2845 !      i = i + 1
2846 !    ENDDO
2847 ! fix 20021112, JM
2848     DO WHILE ( nobreak )
2849       nobreak = .FALSE.
2850       IF ( i .LE. n ) THEN
2851         IF (str(i:i) .NE. ',' ) THEN
2852            tstr(j:j) = str(i:i)
2853            nobreak = .TRUE.
2854         ENDIF
2855       ENDIF
2856       j = j + 1
2857       i = i + 1
2858     ENDDO
2859     IF ( i .GT. n ) nobreakouter = .FALSE.
2860     IF ( varstr(1:varstrn) .EQ. tstr(1:varstrn) ) THEN
2861       retval(1:) = TRIM(tstr(varstrn+1:))
2862       nobreakouter = .FALSE.
2863     ENDIF
2864   ENDDO
2865   RETURN
2866 END SUBROUTINE get_value_from_pairs
2867
2868 LOGICAL FUNCTION multi_files ( io_form )
2869 !<DESCRIPTION>
2870 !<PRE>
2871 ! Returns .TRUE. iff io_form is a multi-file format.  A multi-file format
2872 ! results in one file for each compute process and can be used with any
2873 ! I/O package.  A multi-file dataset can only be read by the same number
2874 ! of tasks that were used to write it.  This feature can be useful for
2875 ! speeding up restarts on machines that support efficient parallel I/O.
2876 ! Multi-file formats cannot be used with I/O quilt servers.
2877 !
2878 ! Note: multi-file is selected by adding 100 to the standard WRF I/O
2879 ! form.  If you add 200 instead, then single-file I/O is still done,
2880 ! but without I/O servers.
2881 !</PRE>
2882 !</DESCRIPTION>
2883   IMPLICIT NONE
2884   INTEGER, INTENT(IN) :: io_form
2885 #ifdef DM_PARALLEL
2886   multi_files = ( io_form >= 100 .and. io_form<200 )
2887 #else
2888   multi_files = .FALSE.
2889 #endif
2890 END FUNCTION multi_files
2891
2892 INTEGER FUNCTION use_package ( io_form )
2893 !<DESCRIPTION>
2894 !<PRE>
2895 ! Returns the ID of the external I/O package referenced by io_form.
2896 !</PRE>
2897 !</DESCRIPTION>
2898   IMPLICIT NONE
2899   INTEGER, INTENT(IN) :: io_form
2900   use_package = MOD( io_form, 100 )
2901 END FUNCTION use_package
2902
2903
2904 SUBROUTINE collect_fld_and_call_pkg (    fcn, donotcollect_arg,                                       &
2905                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2906                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2907                                      DomainStart , DomainEnd ,                                    &
2908                                      MemoryStart , MemoryEnd ,                                    &
2909                                      PatchStart , PatchEnd ,                                      &
2910                                      Status )
2911 !<DESCRIPTION>
2912 !<PRE>
2913 ! The collect_*_and_call_pkg routines collect a distributed array onto one
2914 ! processor and then call an I/O function to write the result (or in the
2915 ! case of replicated data simply write monitor node's copy of the data)
2916 ! This routine handle cases where collection can be skipped and deals with
2917 ! different data types for Field.
2918 !</PRE>
2919 !</DESCRIPTION>
2920   IMPLICIT NONE
2921 #include "wrf_io_flags.h"
2922   EXTERNAL fcn
2923   LOGICAL,        INTENT(IN)    :: donotcollect_arg
2924   INTEGER ,       INTENT(IN)    :: Hndl
2925   CHARACTER*(*) :: DateStr
2926   CHARACTER*(*) :: VarName
2927   INTEGER ,       INTENT(IN)    :: Field(*)
2928   INTEGER                       ,INTENT(IN)    :: FieldType
2929   INTEGER                       ,INTENT(INOUT) :: Comm
2930   INTEGER                       ,INTENT(INOUT) :: IOComm
2931   INTEGER                       ,INTENT(IN)    :: DomainDesc
2932   LOGICAL, DIMENSION(4)                        :: bdy_mask
2933   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
2934   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
2935   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
2936   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
2937   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
2938   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
2939   INTEGER                       ,INTENT(OUT)   :: Status
2940   LOGICAL donotcollect
2941   INTEGER ndims, nproc
2942
2943   CALL dim_from_memorder( MemoryOrder , ndims)
2944   CALL wrf_get_nproc( nproc )
2945   donotcollect = donotcollect_arg .OR. (nproc .EQ. 1)
2946
2947   IF ( donotcollect ) THEN
2948
2949     CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2950                DomainDesc , MemoryOrder , Stagger , DimNames ,                &
2951                DomainStart , DomainEnd ,                                      &
2952                MemoryStart , MemoryEnd ,                                      &
2953                PatchStart , PatchEnd ,                                        &
2954                Status )
2955
2956   ELSE IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
2957
2958      CALL collect_double_and_call_pkg ( fcn,                                        &
2959                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2960                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2961                DomainStart , DomainEnd ,                                    &
2962                MemoryStart , MemoryEnd ,                                    &
2963                PatchStart , PatchEnd ,                                      &
2964                Status )
2965
2966   ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
2967
2968      CALL collect_real_and_call_pkg ( fcn,                                        &
2969                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2970                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2971                DomainStart , DomainEnd ,                                    &
2972                MemoryStart , MemoryEnd ,                                    &
2973                PatchStart , PatchEnd ,                                      &
2974                Status )
2975
2976   ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
2977
2978      CALL collect_int_and_call_pkg ( fcn,                                        &
2979                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2980                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2981                DomainStart , DomainEnd ,                                    &
2982                MemoryStart , MemoryEnd ,                                    &
2983                PatchStart , PatchEnd ,                                      &
2984                Status )
2985
2986   ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
2987
2988      CALL collect_logical_and_call_pkg ( fcn,                                        &
2989                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
2990                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
2991                DomainStart , DomainEnd ,                                    &
2992                MemoryStart , MemoryEnd ,                                    &
2993                PatchStart , PatchEnd ,                                      &
2994                Status )
2995
2996   ENDIF
2997   RETURN
2998 END SUBROUTINE collect_fld_and_call_pkg
2999
3000 SUBROUTINE collect_real_and_call_pkg (   fcn,                                                     &
3001                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3002                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3003                                      DomainStart , DomainEnd ,                                    &
3004                                      MemoryStart , MemoryEnd ,                                    &
3005                                      PatchStart , PatchEnd ,                                      &
3006                                      Status )
3007 !<DESCRIPTION>
3008 !<PRE>
3009 ! The collect_*_and_call_pkg routines collect a distributed array onto one
3010 ! processor and then call an I/O function to write the result (or in the
3011 ! case of replicated data simply write monitor node's copy of the data)
3012 ! The sole purpose of this wrapper is to allocate a big real buffer and
3013 ! pass it down to collect_generic_and_call_pkg() to do the actual work.
3014 !</PRE>
3015 !</DESCRIPTION>
3016   USE module_state_description
3017   USE module_driver_constants
3018   IMPLICIT NONE
3019   EXTERNAL fcn
3020   INTEGER ,       INTENT(IN)    :: Hndl
3021   CHARACTER*(*) :: DateStr
3022   CHARACTER*(*) :: VarName
3023   REAL    ,       INTENT(IN)    :: Field(*)
3024   INTEGER                       ,INTENT(IN)    :: FieldType
3025   INTEGER                       ,INTENT(INOUT) :: Comm
3026   INTEGER                       ,INTENT(INOUT) :: IOComm
3027   INTEGER                       ,INTENT(IN)    :: DomainDesc
3028   LOGICAL, DIMENSION(4)                        :: bdy_mask
3029   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3030   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3031   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3032   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3033   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3034   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3035   INTEGER                       ,INTENT(INOUT)   :: Status
3036   REAL, ALLOCATABLE :: globbuf (:)
3037   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
3038
3039   IF ( wrf_dm_on_monitor() ) THEN
3040     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3041   ELSE
3042     ALLOCATE( globbuf( 1 ) )
3043   ENDIF
3044
3045 #ifdef DEREF_KLUDGE
3046 # define FRSTELEM (1)
3047 #else
3048 # define FRSTELEM
3049 #endif
3050
3051   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM,                                    &
3052                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3053                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3054                                      DomainStart , DomainEnd ,                                    &
3055                                      MemoryStart , MemoryEnd ,                                    &
3056                                      PatchStart , PatchEnd ,                                      &
3057                                      Status )
3058   DEALLOCATE ( globbuf )
3059   RETURN
3060
3061 END SUBROUTINE collect_real_and_call_pkg
3062
3063 SUBROUTINE collect_int_and_call_pkg (   fcn,                                                     &
3064                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3065                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3066                                      DomainStart , DomainEnd ,                                    &
3067                                      MemoryStart , MemoryEnd ,                                    &
3068                                      PatchStart , PatchEnd ,                                      &
3069                                      Status )
3070 !<DESCRIPTION>
3071 !<PRE>
3072 ! The collect_*_and_call_pkg routines collect a distributed array onto one
3073 ! processor and then call an I/O function to write the result (or in the
3074 ! case of replicated data simply write monitor node's copy of the data)
3075 ! The sole purpose of this wrapper is to allocate a big integer buffer and
3076 ! pass it down to collect_generic_and_call_pkg() to do the actual work.
3077 !</PRE>
3078 !</DESCRIPTION>
3079   USE module_state_description
3080   USE module_driver_constants
3081   IMPLICIT NONE
3082   EXTERNAL fcn
3083   INTEGER ,       INTENT(IN)    :: Hndl
3084   CHARACTER*(*) :: DateStr
3085   CHARACTER*(*) :: VarName
3086   INTEGER    ,       INTENT(IN)    :: Field(*)
3087   INTEGER                       ,INTENT(IN)    :: FieldType
3088   INTEGER                       ,INTENT(INOUT) :: Comm
3089   INTEGER                       ,INTENT(INOUT) :: IOComm
3090   INTEGER                       ,INTENT(IN)    :: DomainDesc
3091   LOGICAL, DIMENSION(4)                        :: bdy_mask
3092   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3093   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3094   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3095   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3096   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3097   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3098   INTEGER                       ,INTENT(INOUT)   :: Status
3099   INTEGER, ALLOCATABLE :: globbuf (:)
3100   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
3101
3102   IF ( wrf_dm_on_monitor() ) THEN
3103     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3104   ELSE
3105     ALLOCATE( globbuf( 1 ) )
3106   ENDIF
3107
3108   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
3109                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3110                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3111                                      DomainStart , DomainEnd ,                                    &
3112                                      MemoryStart , MemoryEnd ,                                    &
3113                                      PatchStart , PatchEnd ,                                      &
3114                                      Status )
3115   DEALLOCATE ( globbuf )
3116   RETURN
3117
3118 END SUBROUTINE collect_int_and_call_pkg
3119
3120 SUBROUTINE collect_double_and_call_pkg (   fcn,                                                     &
3121                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3122                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3123                                      DomainStart , DomainEnd ,                                    &
3124                                      MemoryStart , MemoryEnd ,                                    &
3125                                      PatchStart , PatchEnd ,                                      &
3126                                      Status )
3127 !<DESCRIPTION>
3128 !<PRE>
3129 ! The collect_*_and_call_pkg routines collect a distributed array onto one
3130 ! processor and then call an I/O function to write the result (or in the
3131 ! case of replicated data simply write monitor node's copy of the data)
3132 ! The sole purpose of this wrapper is to allocate a big double precision
3133 ! buffer and pass it down to collect_generic_and_call_pkg() to do the
3134 ! actual work.
3135 !</PRE>
3136 !</DESCRIPTION>
3137   USE module_state_description
3138   USE module_driver_constants
3139   IMPLICIT NONE
3140   EXTERNAL fcn
3141   INTEGER ,       INTENT(IN)    :: Hndl
3142   CHARACTER*(*) :: DateStr
3143   CHARACTER*(*) :: VarName
3144   DOUBLE PRECISION    ,       INTENT(IN)    :: Field(*)
3145   INTEGER                       ,INTENT(IN)    :: FieldType
3146   INTEGER                       ,INTENT(INOUT) :: Comm
3147   INTEGER                       ,INTENT(INOUT) :: IOComm
3148   INTEGER                       ,INTENT(IN)    :: DomainDesc
3149   LOGICAL, DIMENSION(4)                        :: bdy_mask
3150   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3151   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3152   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3153   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3154   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3155   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3156   INTEGER                       ,INTENT(INOUT)   :: Status
3157   DOUBLE PRECISION, ALLOCATABLE :: globbuf (:)
3158   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
3159
3160   IF ( wrf_dm_on_monitor() ) THEN
3161     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3162   ELSE
3163     ALLOCATE( globbuf( 1 ) )
3164   ENDIF
3165
3166   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
3167                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3168                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3169                                      DomainStart , DomainEnd ,                                    &
3170                                      MemoryStart , MemoryEnd ,                                    &
3171                                      PatchStart , PatchEnd ,                                      &
3172                                      Status )
3173   DEALLOCATE ( globbuf )
3174   RETURN
3175
3176 END SUBROUTINE collect_double_and_call_pkg
3177
3178 SUBROUTINE collect_logical_and_call_pkg (   fcn,                                                     &
3179                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3180                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3181                                      DomainStart , DomainEnd ,                                    &
3182                                      MemoryStart , MemoryEnd ,                                    &
3183                                      PatchStart , PatchEnd ,                                      &
3184                                      Status )
3185 !<DESCRIPTION>
3186 !<PRE>
3187 ! The collect_*_and_call_pkg routines collect a distributed array onto one
3188 ! processor and then call an I/O function to write the result (or in the
3189 ! case of replicated data simply write monitor node's copy of the data)
3190 ! The sole purpose of this wrapper is to allocate a big logical buffer
3191 ! and pass it down to collect_generic_and_call_pkg() to do the actual work.
3192 !</PRE>
3193 !</DESCRIPTION>
3194   USE module_state_description
3195   USE module_driver_constants
3196   IMPLICIT NONE
3197   EXTERNAL fcn
3198   INTEGER ,       INTENT(IN)    :: Hndl
3199   CHARACTER*(*) :: DateStr
3200   CHARACTER*(*) :: VarName
3201   LOGICAL    ,       INTENT(IN)    :: Field(*)
3202   INTEGER                       ,INTENT(IN)    :: FieldType
3203   INTEGER                       ,INTENT(INOUT) :: Comm
3204   INTEGER                       ,INTENT(INOUT) :: IOComm
3205   INTEGER                       ,INTENT(IN)    :: DomainDesc
3206   LOGICAL, DIMENSION(4)                        :: bdy_mask
3207   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3208   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3209   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3210   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3211   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3212   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3213   INTEGER                       ,INTENT(INOUT)   :: Status
3214   LOGICAL, ALLOCATABLE :: globbuf (:)
3215   LOGICAL, EXTERNAL           :: wrf_dm_on_monitor
3216
3217   IF ( wrf_dm_on_monitor() ) THEN
3218     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3219   ELSE
3220     ALLOCATE( globbuf( 1 ) )
3221   ENDIF
3222
3223   CALL collect_generic_and_call_pkg (   fcn, globbuf FRSTELEM ,                                   &
3224                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3225                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3226                                      DomainStart , DomainEnd ,                                    &
3227                                      MemoryStart , MemoryEnd ,                                    &
3228                                      PatchStart , PatchEnd ,                                      &
3229                                      Status )
3230   DEALLOCATE ( globbuf )
3231   RETURN
3232
3233 END SUBROUTINE collect_logical_and_call_pkg
3234
3235
3236 SUBROUTINE collect_generic_and_call_pkg ( fcn, globbuf,                                           &
3237                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3238                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,    &
3239                                      DomainStart , DomainEnd ,                                    &
3240                                      MemoryStart , MemoryEnd ,                                    &
3241                                      PatchStart , PatchEnd ,                                      &
3242                                      Status )
3243 !<DESCRIPTION>
3244 !<PRE>
3245 ! The collect_*_and_call_pkg routines collect a distributed array onto one
3246 ! processor and then call an I/O function to write the result (or in the
3247 ! case of replicated data simply write monitor node's copy of the data)
3248 ! This routine calls the distributed memory communication routines that
3249 ! collect the array and then calls I/O function fcn to write it to disk.
3250 !</PRE>
3251 !</DESCRIPTION>
3252   USE module_state_description
3253   USE module_driver_constants
3254   IMPLICIT NONE
3255 #include "wrf_io_flags.h"
3256 #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
3257 include "mpif.h"
3258 #endif
3259   EXTERNAL fcn
3260   REAL , DIMENSION(*) , INTENT(INOUT) :: globbuf
3261   INTEGER ,       INTENT(IN)    :: Hndl
3262   CHARACTER*(*) :: DateStr
3263   CHARACTER*(*) :: VarName
3264   REAL    ,       INTENT(IN)    :: Field(*)
3265   INTEGER                       ,INTENT(IN)    :: FieldType
3266   INTEGER                       ,INTENT(INOUT) :: Comm
3267   INTEGER                       ,INTENT(INOUT) :: IOComm
3268   INTEGER                       ,INTENT(IN)    :: DomainDesc
3269   LOGICAL, DIMENSION(4)                        :: bdy_mask
3270   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3271   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3272   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3273   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3274   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3275   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3276   INTEGER                       ,INTENT(OUT)   :: Status
3277   CHARACTER*3 MemOrd
3278   LOGICAL, EXTERNAL :: has_char
3279   INTEGER ids, ide, jds, jde, kds, kde
3280   INTEGER ims, ime, jms, jme, kms, kme
3281   INTEGER ips, ipe, jps, jpe, kps, kpe
3282   INTEGER, ALLOCATABLE :: counts(:), displs(:)
3283   INTEGER nproc, communicator, mpi_bdyslice_type, ierr, my_displ
3284   INTEGER my_count
3285   INTEGER , dimension(3)                       :: dom_end_rev
3286   LOGICAL, EXTERNAL         :: wrf_dm_on_monitor
3287   INTEGER, EXTERNAL         :: wrf_dm_monitor_rank
3288   LOGICAL     distributed_field
3289   INTEGER i,j,k,idx,lx,idx2,lx2
3290   INTEGER collective_root
3291
3292   CALL wrf_get_nproc( nproc )
3293   CALL wrf_get_dm_communicator ( communicator )
3294
3295   ALLOCATE( counts( nproc ) )
3296   ALLOCATE( displs( nproc ) )
3297   CALL lower_case( MemoryOrder, MemOrd )
3298
3299   collective_root = wrf_dm_monitor_rank()
3300
3301   dom_end_rev(1) = DomainEnd(1)
3302   dom_end_rev(2) = DomainEnd(2)
3303   dom_end_rev(3) = DomainEnd(3)
3304
3305   SELECT CASE (TRIM(MemOrd))
3306     CASE (  'xzy' )
3307       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3308       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3309       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3310     CASE (  'zxy' )
3311       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3312       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3313       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3314     CASE (  'xyz' )
3315       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3316       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3317       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3318     CASE (  'xy' )
3319       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3320       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3321     CASE (  'yxz' )
3322       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3323       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3324       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
3325     CASE (  'yx' )
3326       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
3327       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
3328     CASE DEFAULT
3329       ! do nothing; the boundary orders and others either dont care or set themselves
3330   END SELECT
3331
3332   SELECT CASE (TRIM(MemOrd))
3333 #ifndef STUBMPI
3334     CASE (  'xzy','zxy','xyz','yxz','xy','yx' )
3335
3336       distributed_field = .TRUE.
3337       IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3338         CALL wrf_patch_to_global_double ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
3339            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3340            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3341            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3342       ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3343         CALL wrf_patch_to_global_real ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
3344            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3345            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3346            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3347       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3348         CALL wrf_patch_to_global_integer ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
3349            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3350            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3351            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3352       ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3353         CALL wrf_patch_to_global_logical ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
3354            DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
3355            MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
3356            PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
3357       ENDIF
3358
3359 #if defined(DM_PARALLEL) && !defined(STUBMPI)
3360     CASE ( 'xsz', 'xez' )
3361       distributed_field = .FALSE.
3362       IF ( nproc .GT. 1 ) THEN
3363         jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1  ! ns strip
3364         kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1  ! levels
3365         ids = DomainStart(3) ; ide = DomainEnd(3) ; !  bdy_width
3366         dom_end_rev(1) = jde
3367         dom_end_rev(2) = kde
3368         dom_end_rev(3) = ide
3369         distributed_field = .TRUE.
3370         IF ( (MemOrd .eq. 'xsz' .AND. bdy_mask( P_XSB )) .OR.     &
3371              (MemOrd .eq. 'xez' .AND. bdy_mask( P_XEB ))       ) THEN
3372           my_displ = PatchStart(1)-1
3373           my_count = PatchEnd(1)-PatchStart(1)+1
3374         ELSE
3375           my_displ = 0
3376           my_count = 0
3377         ENDIF
3378         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3379         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3380         do i = DomainStart(3),DomainEnd(3)    ! bdy_width
3381         do k = DomainStart(2),DomainEnd(2)    ! levels
3382            lx   = MemoryEnd(1)-MemoryStart(1)+1
3383            lx2  = dom_end_rev(1)-DomainStart(1)+1
3384            idx  = lx*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3385            idx2 = lx2*((k-1)+(i-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3386            IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
3387
3388              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3389                              my_count ,                       &    ! sendcount
3390                              globbuf, 1+idx2 ,                &    ! recvbuf
3391                              counts                         , &    ! recvcounts
3392                              displs                         , &    ! displs
3393                              collective_root                , &    ! root
3394                              communicator                   , &    ! communicator
3395                              ierr )
3396
3397            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3398
3399              CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3400                              my_count ,                       &    ! sendcount
3401                              globbuf, 1+idx2 ,                &    ! recvbuf
3402                              counts                         , &    ! recvcounts
3403                              displs                         , &    ! displs
3404                              collective_root                , &    ! root
3405                              communicator                   , &    ! communicator
3406                              ierr )
3407
3408            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3409
3410              CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3411                              my_count ,                       &    ! sendcount
3412                              globbuf, 1+idx2 ,                &    ! recvbuf
3413                              counts                         , &    ! recvcounts
3414                              displs                         , &    ! displs
3415                              collective_root                , &    ! root
3416                              communicator                   , &    ! communicator
3417                              ierr )
3418            ENDIF
3419
3420         enddo
3421         enddo
3422       ENDIF
3423     CASE ( 'xs', 'xe' )
3424       distributed_field = .FALSE.
3425       IF ( nproc .GT. 1 ) THEN
3426         jds = DomainStart(1) ; jde = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) jde = jde+1  ! ns strip
3427         ids = DomainStart(2) ; ide = DomainEnd(2) ; !  bdy_width
3428         dom_end_rev(1) = jde
3429         dom_end_rev(2) = ide
3430         distributed_field = .TRUE.
3431         IF ( (MemOrd .eq. 'xs' .AND. bdy_mask( P_XSB )) .OR.     &
3432              (MemOrd .eq. 'xe' .AND. bdy_mask( P_XEB ))       ) THEN
3433           my_displ = PatchStart(1)-1
3434           my_count = PatchEnd(1)-PatchStart(1)+1
3435         ELSE
3436           my_displ = 0
3437           my_count = 0
3438         ENDIF
3439         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3440         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3441         do i = DomainStart(2),DomainEnd(2)    ! bdy_width
3442            lx   = MemoryEnd(1)-MemoryStart(1)+1
3443            idx  = lx*(i-1)
3444            lx2  = dom_end_rev(1)-DomainStart(1)+1
3445            idx2 = lx2*(i-1)
3446            IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3447
3448              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3449                              my_count ,                       &    ! sendcount
3450                              globbuf, 1+idx2 ,                &    ! recvbuf
3451                              counts                         , &    ! recvcounts
3452                              displs                         , &    ! displs
3453                              collective_root                , &    ! root
3454                              communicator                   , &    ! communicator
3455                              ierr )
3456
3457            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3458
3459              CALL wrf_gatherv_real ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3460                              my_count ,                       &    ! sendcount
3461                              globbuf, 1+idx2 ,                &    ! recvbuf
3462                              counts                         , &    ! recvcounts
3463                              displs                         , &    ! displs
3464                              collective_root                , &    ! root
3465                              communicator                   , &    ! communicator
3466                              ierr )
3467
3468            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3469
3470              CALL wrf_gatherv_integer ( Field, PatchStart(1)-MemoryStart(1)+1+idx , &
3471                              my_count ,                       &    ! sendcount
3472                              globbuf, 1+idx2 ,                &    ! recvbuf
3473                              counts                         , &    ! recvcounts
3474                              displs                         , &    ! displs
3475                              collective_root                , &    ! root
3476                              communicator                   , &    ! communicator
3477                              ierr )
3478            ENDIF
3479
3480         enddo
3481       ENDIF
3482     CASE ( 'ysz', 'yez' )
3483       distributed_field = .FALSE.
3484       IF ( nproc .GT. 1 ) THEN
3485         ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1  ! ns strip
3486         kds = DomainStart(2) ; kde = DomainEnd(2) ; IF ( .NOT. has_char( Stagger, 'z' ) ) kde = kde+1  ! levels
3487         jds = DomainStart(3) ; jde = DomainEnd(3) ; !  bdy_width
3488         dom_end_rev(1) = ide
3489         dom_end_rev(2) = kde
3490         dom_end_rev(3) = jde
3491         distributed_field = .TRUE.
3492         IF ( (MemOrd .eq. 'ysz' .AND. bdy_mask( P_YSB )) .OR.     &
3493              (MemOrd .eq. 'yez' .AND. bdy_mask( P_YEB ))       ) THEN
3494           my_displ = PatchStart(1)-1
3495           my_count = PatchEnd(1)-PatchStart(1)+1
3496         ELSE
3497           my_displ = 0
3498           my_count = 0
3499         ENDIF
3500         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3501         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3502         do j = DomainStart(3),DomainEnd(3)    ! bdy_width
3503         do k = DomainStart(2),DomainEnd(2)    ! levels
3504            lx   = MemoryEnd(1)-MemoryStart(1)+1
3505            lx2  = dom_end_rev(1)-DomainStart(1)+1
3506            idx  = lx*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3507            idx2 = lx2*((k-1)+(j-1)*(MemoryEnd(2)-MemoryStart(2)+1))
3508
3509            IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3510
3511              CALL wrf_gatherv_double ( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3512                              my_count                       , &    ! sendcount
3513                              globbuf, 1+idx2                , &    ! recvbuf
3514                              counts                         , &    ! recvcounts
3515                              displs                         , &    ! displs
3516                              collective_root                , &    ! root
3517                              communicator                   , &    ! communicator
3518                              ierr )
3519
3520            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3521
3522              CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3523                              my_count                       , &    ! sendcount
3524                              globbuf, 1+idx2                , &    ! recvbuf
3525                              counts                         , &    ! recvcounts
3526                              displs                         , &    ! displs
3527                              collective_root                , &    ! root
3528                              communicator                   , &    ! communicator
3529                              ierr )
3530
3531            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3532
3533              CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3534                              my_count                       , &    ! sendcount
3535                              globbuf, 1+idx2                , &    ! recvbuf
3536                              counts                         , &    ! recvcounts
3537                              displs                         , &    ! displs
3538                              collective_root                , &    ! root
3539                              communicator                   , &    ! communicator
3540                              ierr )
3541            ENDIF
3542
3543         enddo
3544         enddo
3545       ENDIF
3546     CASE ( 'ys', 'ye' )
3547       distributed_field = .FALSE.
3548       IF ( nproc .GT. 1 ) THEN
3549         ids = DomainStart(1) ; ide = DomainEnd(1) ; IF ( .NOT. has_char( Stagger, 'y' ) ) ide = ide+1  ! ns strip
3550         jds = DomainStart(2) ; jde = DomainEnd(2) ; !  bdy_width
3551         dom_end_rev(1) = ide
3552         dom_end_rev(2) = jde
3553         distributed_field = .TRUE.
3554         IF ( (MemOrd .eq. 'ys' .AND. bdy_mask( P_YSB )) .OR.     &
3555              (MemOrd .eq. 'ye' .AND. bdy_mask( P_YEB ))       ) THEN
3556           my_displ = PatchStart(1)-1
3557           my_count = PatchEnd(1)-PatchStart(1)+1
3558         ELSE
3559           my_displ = 0
3560           my_count = 0
3561         ENDIF
3562         CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
3563         CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
3564         do j = DomainStart(2),DomainEnd(2)    ! bdy_width
3565            lx   = MemoryEnd(1)-MemoryStart(1)+1
3566            idx  = lx*(j-1)
3567            lx2  = dom_end_rev(1)-DomainStart(1)+1
3568            idx2 = lx2*(j-1)
3569
3570            IF ( FieldType .EQ. WRF_DOUBLE ) THEN
3571
3572              CALL wrf_gatherv_double( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3573                              my_count                       , &    ! sendcount
3574                              globbuf, 1+idx2                , &    ! recvbuf
3575                              counts                         , &    ! recvcounts
3576                              displs                         , &    ! displs
3577                              collective_root                , &    ! root
3578                              communicator                   , &    ! communicator
3579                              ierr )
3580
3581            ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
3582
3583              CALL wrf_gatherv_real( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3584                              my_count                       , &    ! sendcount
3585                              globbuf, 1+idx2                , &    ! recvbuf
3586                              counts                         , &    ! recvcounts
3587                              displs                         , &    ! displs
3588                              collective_root                , &    ! root
3589                              communicator                   , &    ! communicator
3590                              ierr )
3591
3592            ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3593
3594              CALL wrf_gatherv_integer( Field, PatchStart(1)-MemoryStart(1)+1+idx ,      &    ! sendbuf
3595                              my_count                       , &    ! sendcount
3596                              globbuf, 1+idx2                , &    ! recvbuf
3597                              counts                         , &    ! recvcounts
3598                              displs                         , &    ! displs
3599                              collective_root                , &    ! root
3600                              communicator                   , &    ! communicator
3601                              ierr )
3602            ENDIF
3603
3604         enddo
3605       ENDIF
3606 #endif
3607 #endif
3608     CASE DEFAULT
3609       distributed_field = .FALSE.
3610   END SELECT
3611   IF ( wrf_dm_on_monitor() ) THEN
3612     IF ( distributed_field ) THEN
3613       CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
3614                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
3615                  DomainStart , DomainEnd ,                                        &
3616                  DomainStart , dom_end_rev ,                                      &  ! memory dims adjust out for unstag
3617                  DomainStart , DomainEnd ,                                        &
3618                  Status )
3619     ELSE
3620       CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3621                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
3622                  DomainStart , DomainEnd ,                                        &
3623                  MemoryStart , MemoryEnd ,                                        &
3624                  PatchStart  , PatchEnd  ,                                        &
3625                  Status )
3626     ENDIF
3627   ENDIF
3628   CALL wrf_dm_bcast_bytes( Status , IWORDSIZE )
3629   DEALLOCATE( counts )
3630   DEALLOCATE( displs )
3631   RETURN
3632 END SUBROUTINE collect_generic_and_call_pkg
3633
3634
3635 SUBROUTINE call_pkg_and_dist (       fcn, donotdist_arg, update_arg,                           &
3636                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3637                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3638                                      DomainStart , DomainEnd ,                                    &
3639                                      MemoryStart , MemoryEnd ,                                    &
3640                                      PatchStart , PatchEnd ,                                      &
3641                                      Status )
3642 !<DESCRIPTION>
3643 !<PRE>
3644 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3645 ! distribute or replicate the field across compute tasks.
3646 ! This routine handle cases where distribution/replication can be skipped and
3647 ! deals with different data types for Field.
3648 !</PRE>
3649 !</DESCRIPTION>
3650   IMPLICIT NONE
3651 #include "wrf_io_flags.h"
3652   EXTERNAL fcn
3653   LOGICAL,        INTENT(IN)    :: donotdist_arg, update_arg  ! update means collect old field update it and dist
3654   INTEGER ,       INTENT(IN)    :: Hndl
3655   CHARACTER*(*) :: DateStr
3656   CHARACTER*(*) :: VarName
3657   INTEGER                          :: Field(*)
3658   INTEGER                                      :: FieldType
3659   INTEGER                                      :: Comm
3660   INTEGER                                      :: IOComm
3661   INTEGER                                      :: DomainDesc
3662   LOGICAL, DIMENSION(4)                        :: bdy_mask
3663   CHARACTER*(*)                                :: MemoryOrder
3664   CHARACTER*(*)                                :: Stagger
3665   CHARACTER*(*) , dimension (*)                :: DimNames
3666   INTEGER ,dimension(*)                        :: DomainStart, DomainEnd
3667   INTEGER ,dimension(*)                        :: MemoryStart, MemoryEnd
3668   INTEGER ,dimension(*)                        :: PatchStart,  PatchEnd
3669   INTEGER                                      :: Status
3670   LOGICAL donotdist
3671   INTEGER ndims, nproc
3672
3673   CALL dim_from_memorder( MemoryOrder , ndims)
3674   CALL wrf_get_nproc( nproc )
3675   donotdist = donotdist_arg .OR. (nproc .EQ. 1)
3676
3677   IF ( donotdist ) THEN
3678     CALL fcn ( Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3679                DomainDesc , MemoryOrder , Stagger , DimNames ,                &
3680                DomainStart , DomainEnd ,                                      &
3681                MemoryStart , MemoryEnd ,                                      &
3682                PatchStart , PatchEnd ,                                        &
3683                Status )
3684
3685   ELSE IF (FieldType .EQ. WRF_DOUBLE) THEN
3686
3687      CALL call_pkg_and_dist_double ( fcn, update_arg,                            &
3688                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3689                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3690                DomainStart , DomainEnd ,                                    &
3691                MemoryStart , MemoryEnd ,                                    &
3692                PatchStart , PatchEnd ,                                      &
3693                Status )
3694
3695   ELSE IF (FieldType .EQ. WRF_FLOAT) THEN
3696
3697      CALL call_pkg_and_dist_real ( fcn, update_arg,                            &
3698                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3699                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3700                DomainStart , DomainEnd ,                                    &
3701                MemoryStart , MemoryEnd ,                                    &
3702                PatchStart , PatchEnd ,                                      &
3703                Status )
3704
3705   ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
3706
3707      CALL call_pkg_and_dist_int ( fcn, update_arg,                            &
3708                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3709                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3710                DomainStart , DomainEnd ,                                    &
3711                MemoryStart , MemoryEnd ,                                    &
3712                PatchStart , PatchEnd ,                                      &
3713                Status )
3714
3715   ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
3716
3717      CALL call_pkg_and_dist_logical ( fcn, update_arg,                            &
3718                Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3719                DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3720                DomainStart , DomainEnd ,                                    &
3721                MemoryStart , MemoryEnd ,                                    &
3722                PatchStart , PatchEnd ,                                      &
3723                Status )
3724
3725   ENDIF
3726   RETURN
3727 END SUBROUTINE call_pkg_and_dist
3728
3729 SUBROUTINE call_pkg_and_dist_real (  fcn, update_arg,                                             &
3730                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3731                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3732                                      DomainStart , DomainEnd ,                                    &
3733                                      MemoryStart , MemoryEnd ,                                    &
3734                                      PatchStart , PatchEnd ,                                      &
3735                                      Status )
3736 !<DESCRIPTION>
3737 !<PRE>
3738 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3739 ! distribute or replicate the field across compute tasks.
3740 ! The sole purpose of this wrapper is to allocate a big real buffer and
3741 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3742 !</PRE>
3743 !</DESCRIPTION>
3744   IMPLICIT NONE
3745   EXTERNAL fcn
3746   INTEGER ,       INTENT(IN)    :: Hndl
3747   LOGICAL ,       INTENT(IN)    :: update_arg
3748   CHARACTER*(*) :: DateStr
3749   CHARACTER*(*) :: VarName
3750   REAL    ,       INTENT(INOUT)    :: Field(*)
3751   INTEGER                       ,INTENT(IN)    :: FieldType
3752   INTEGER                       ,INTENT(INOUT) :: Comm
3753   INTEGER                       ,INTENT(INOUT) :: IOComm
3754   INTEGER                       ,INTENT(IN)    :: DomainDesc
3755   LOGICAL, DIMENSION(4)                        :: bdy_mask
3756   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3757   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3758   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3759   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3760   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3761   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3762   INTEGER                       ,INTENT(INOUT)   :: Status
3763   REAL, ALLOCATABLE :: globbuf (:)
3764   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3765   INTEGER test
3766   CHARACTER*128 mess
3767
3768   IF ( wrf_dm_on_monitor() ) THEN
3769     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ), &
3770               STAT=test )
3771     IF ( test .NE. 0 ) THEN
3772       write(mess,*)"module_io.b",'allocating globbuf ',&
3773            (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3)
3774       CALL wrf_error_fatal(mess)
3775     ENDIF
3776   ELSE
3777     ALLOCATE( globbuf( 1 ), STAT=test )
3778     IF ( test .NE. 0 ) THEN
3779       write(mess,*)"module_io.b",'allocating globbuf ',1
3780       CALL wrf_error_fatal(mess)
3781     ENDIF
3782   ENDIF
3783
3784   globbuf = 0.
3785
3786   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg,                          &
3787                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3788                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3789                                      DomainStart , DomainEnd ,                                    &
3790                                      MemoryStart , MemoryEnd ,                                    &
3791                                      PatchStart , PatchEnd ,                                      &
3792                                      Status )
3793   DEALLOCATE ( globbuf )
3794   RETURN
3795 END SUBROUTINE call_pkg_and_dist_real
3796
3797
3798 SUBROUTINE call_pkg_and_dist_double  (  fcn, update_arg ,                                            &
3799                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3800                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3801                                      DomainStart , DomainEnd ,                                    &
3802                                      MemoryStart , MemoryEnd ,                                    &
3803                                      PatchStart , PatchEnd ,                                      &
3804                                      Status )
3805 !<DESCRIPTION>
3806 !<PRE>
3807 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3808 ! distribute or replicate the field across compute tasks.
3809 ! The sole purpose of this wrapper is to allocate a big double precision buffer
3810 ! and pass it down to call_pkg_and_dist_generic() to do the actual work.
3811 !</PRE>
3812 !</DESCRIPTION>
3813   IMPLICIT NONE
3814   EXTERNAL fcn
3815   INTEGER ,       INTENT(IN)    :: Hndl
3816   LOGICAL ,       INTENT(IN)    :: update_arg
3817   CHARACTER*(*) :: DateStr
3818   CHARACTER*(*) :: VarName
3819   DOUBLE PRECISION   ,       INTENT(INOUT)    :: Field(*)
3820   INTEGER                       ,INTENT(IN)    :: FieldType
3821   INTEGER                       ,INTENT(INOUT) :: Comm
3822   INTEGER                       ,INTENT(INOUT) :: IOComm
3823   INTEGER                       ,INTENT(IN)    :: DomainDesc
3824   LOGICAL, DIMENSION(4)                        :: bdy_mask
3825   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3826   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3827   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3828   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3829   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3830   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3831   INTEGER                       ,INTENT(INOUT)   :: Status
3832   DOUBLE PRECISION , ALLOCATABLE :: globbuf (:)
3833   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3834
3835   IF ( wrf_dm_on_monitor() ) THEN
3836     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3837   ELSE
3838     ALLOCATE( globbuf( 1 ) )
3839   ENDIF
3840
3841   globbuf = 0
3842
3843   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                         &
3844                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3845                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3846                                      DomainStart , DomainEnd ,                                    &
3847                                      MemoryStart , MemoryEnd ,                                    &
3848                                      PatchStart , PatchEnd ,                                      &
3849                                      Status )
3850   DEALLOCATE ( globbuf )
3851   RETURN
3852 END SUBROUTINE call_pkg_and_dist_double
3853
3854
3855 SUBROUTINE call_pkg_and_dist_int  (  fcn, update_arg ,                                            &
3856                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3857                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3858                                      DomainStart , DomainEnd ,                                    &
3859                                      MemoryStart , MemoryEnd ,                                    &
3860                                      PatchStart , PatchEnd ,                                      &
3861                                      Status )
3862 !<DESCRIPTION>
3863 !<PRE>
3864 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3865 ! distribute or replicate the field across compute tasks.
3866 ! The sole purpose of this wrapper is to allocate a big integer buffer and
3867 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3868 !</PRE>
3869 !</DESCRIPTION>
3870   IMPLICIT NONE
3871   EXTERNAL fcn
3872   INTEGER ,       INTENT(IN)    :: Hndl
3873   LOGICAL ,       INTENT(IN)    :: update_arg
3874   CHARACTER*(*) :: DateStr
3875   CHARACTER*(*) :: VarName
3876   INTEGER    ,       INTENT(INOUT)    :: Field(*)
3877   INTEGER                       ,INTENT(IN)    :: FieldType
3878   INTEGER                       ,INTENT(INOUT) :: Comm
3879   INTEGER                       ,INTENT(INOUT) :: IOComm
3880   INTEGER                       ,INTENT(IN)    :: DomainDesc
3881   LOGICAL, DIMENSION(4)                        :: bdy_mask
3882   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3883   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3884   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3885   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3886   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3887   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3888   INTEGER                       ,INTENT(INOUT)   :: Status
3889   INTEGER , ALLOCATABLE :: globbuf (:)
3890   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3891
3892   IF ( wrf_dm_on_monitor() ) THEN
3893     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3894   ELSE
3895     ALLOCATE( globbuf( 1 ) )
3896   ENDIF
3897
3898   globbuf = 0
3899
3900   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                                  &
3901                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3902                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3903                                      DomainStart , DomainEnd ,                                    &
3904                                      MemoryStart , MemoryEnd ,                                    &
3905                                      PatchStart , PatchEnd ,                                      &
3906                                      Status )
3907   DEALLOCATE ( globbuf )
3908   RETURN
3909 END SUBROUTINE call_pkg_and_dist_int
3910
3911
3912 SUBROUTINE call_pkg_and_dist_logical  (  fcn, update_arg ,                                            &
3913                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3914                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3915                                      DomainStart , DomainEnd ,                                    &
3916                                      MemoryStart , MemoryEnd ,                                    &
3917                                      PatchStart , PatchEnd ,                                      &
3918                                      Status )
3919 !<DESCRIPTION>
3920 !<PRE>
3921 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3922 ! distribute or replicate the field across compute tasks.
3923 ! The sole purpose of this wrapper is to allocate a big logical buffer and
3924 ! pass it down to call_pkg_and_dist_generic() to do the actual work.
3925 !</PRE>
3926 !</DESCRIPTION>
3927   IMPLICIT NONE
3928   EXTERNAL fcn
3929   INTEGER ,       INTENT(IN)    :: Hndl
3930   LOGICAL ,       INTENT(IN)    :: update_arg
3931   CHARACTER*(*) :: DateStr
3932   CHARACTER*(*) :: VarName
3933   logical    ,       INTENT(INOUT)    :: Field(*)
3934   INTEGER                       ,INTENT(IN)    :: FieldType
3935   INTEGER                       ,INTENT(INOUT) :: Comm
3936   INTEGER                       ,INTENT(INOUT) :: IOComm
3937   INTEGER                       ,INTENT(IN)    :: DomainDesc
3938   LOGICAL, DIMENSION(4)                        :: bdy_mask
3939   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
3940   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
3941   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
3942   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
3943   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
3944   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
3945   INTEGER                       ,INTENT(INOUT)   :: Status
3946   LOGICAL , ALLOCATABLE :: globbuf (:)
3947   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
3948
3949   IF ( wrf_dm_on_monitor() ) THEN
3950     ALLOCATE( globbuf( (DomainEnd(1)-DomainStart(1)+3)*(DomainEnd(2)-DomainStart(2)+3)*(DomainEnd(3)-DomainStart(3)+3) ) )
3951   ELSE
3952     ALLOCATE( globbuf( 1 ) )
3953   ENDIF
3954
3955   globbuf = .false.
3956
3957   CALL call_pkg_and_dist_generic (   fcn, globbuf FRSTELEM , update_arg ,                         &
3958                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3959                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3960                                      DomainStart , DomainEnd ,                                    &
3961                                      MemoryStart , MemoryEnd ,                                    &
3962                                      PatchStart , PatchEnd ,                                      &
3963                                      Status )
3964   DEALLOCATE ( globbuf )
3965   RETURN
3966 END SUBROUTINE call_pkg_and_dist_logical
3967
3968 SUBROUTINE call_pkg_and_dist_generic (   fcn, globbuf , update_arg ,                                  &
3969                                      Hndl , DateStr , VarName , Field , FieldType , Comm , IOComm , &
3970                                      DomainDesc , bdy_mask, MemoryOrder , Stagger , DimNames ,              &
3971                                      DomainStart , DomainEnd ,                                    &
3972                                      MemoryStart , MemoryEnd ,                                    &
3973                                      PatchStart , PatchEnd ,                                      &
3974                                      Status )
3975
3976 !<DESCRIPTION>
3977 !<PRE>
3978 ! The call_pkg_and_dist* routines call an I/O function to read a field and then
3979 ! distribute or replicate the field across compute tasks.
3980 ! This routine calls I/O function fcn to read the field from disk and then calls
3981 ! the distributed memory communication routines that distribute or replicate the
3982 ! array.
3983 !</PRE>
3984 !</DESCRIPTION>
3985   USE module_state_description
3986   USE module_driver_constants
3987   USE module_io
3988   IMPLICIT NONE
3989 #include "wrf_io_flags.h"
3990 #if defined( DM_PARALLEL ) && ! defined(STUBMPI)
3991 include "mpif.h"
3992 #endif
3993
3994   EXTERNAL fcn
3995   REAL, DIMENSION(*) ::  globbuf
3996   INTEGER ,       INTENT(IN)    :: Hndl
3997   LOGICAL ,       INTENT(IN)    :: update_arg
3998   CHARACTER*(*) :: DateStr
3999   CHARACTER*(*) :: VarName
4000   REAL                           :: Field(*)
4001   INTEGER                       ,INTENT(IN)    :: FieldType
4002   INTEGER                       ,INTENT(INOUT) :: Comm
4003   INTEGER                       ,INTENT(INOUT) :: IOComm
4004   INTEGER                       ,INTENT(IN)    :: DomainDesc
4005   LOGICAL, DIMENSION(4)                        :: bdy_mask
4006   CHARACTER*(*)                 ,INTENT(IN)    :: MemoryOrder
4007   CHARACTER*(*)                 ,INTENT(IN)    :: Stagger
4008   CHARACTER*(*) , dimension (*) ,INTENT(IN)    :: DimNames
4009   INTEGER ,dimension(*)         ,INTENT(IN)    :: DomainStart, DomainEnd
4010   INTEGER ,dimension(*)         ,INTENT(IN)    :: MemoryStart, MemoryEnd
4011   INTEGER ,dimension(*)         ,INTENT(IN)    :: PatchStart,  PatchEnd
4012   INTEGER                       ,INTENT(OUT)   :: Status
4013   CHARACTER*3 MemOrd
4014   LOGICAL, EXTERNAL :: has_char
4015   INTEGER ids, ide, jds, jde, kds, kde
4016   INTEGER ims, ime, jms, jme, kms, kme
4017   INTEGER ips, ipe, jps, jpe, kps, kpe
4018   INTEGER , dimension(3)                       :: dom_end_rev
4019   INTEGER memsize
4020   LOGICAL, EXTERNAL :: wrf_dm_on_monitor
4021   INTEGER, EXTERNAL :: wrf_dm_monitor_rank
4022
4023   INTEGER lx, lx2, i,j,k ,idx,idx2
4024   INTEGER my_count, nproc, communicator, ierr, my_displ
4025
4026   INTEGER, ALLOCATABLE :: counts(:), displs(:)
4027
4028   LOGICAL distributed_field
4029   INTEGER collective_root
4030
4031   CALL lower_case( MemoryOrder, MemOrd )
4032
4033   collective_root = wrf_dm_monitor_rank()
4034
4035   CALL wrf_get_nproc( nproc )
4036   CALL wrf_get_dm_communicator ( communicator )
4037
4038   ALLOCATE(displs( nproc ))
4039   ALLOCATE(counts( nproc ))
4040
4041   dom_end_rev(1) = DomainEnd(1)
4042   dom_end_rev(2) = DomainEnd(2)
4043   dom_end_rev(3) = DomainEnd(3)
4044
4045   SELECT CASE (TRIM(MemOrd))
4046     CASE (  'xzy' )
4047       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4048       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4049       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
4050     CASE (  'zxy' )
4051       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4052       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4053       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
4054     CASE (  'xyz' )
4055       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4056       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4057       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
4058     CASE (  'xy' )
4059       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4060       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4061     CASE (  'yxz' )
4062       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4063       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4064       IF ( .NOT. has_char( Stagger, 'z' ) ) dom_end_rev(3) = dom_end_rev(3) + 1
4065     CASE (  'yx' )
4066       IF ( .NOT. has_char( Stagger, 'y' ) ) dom_end_rev(1) = dom_end_rev(1) + 1
4067       IF ( .NOT. has_char( Stagger, 'x' ) ) dom_end_rev(2) = dom_end_rev(2) + 1
4068     CASE DEFAULT
4069       ! do nothing; the boundary orders and others either dont care or set themselves
4070   END SELECT
4071
4072   data_ordering : SELECT CASE ( model_data_order )
4073     CASE  ( DATA_ORDER_XYZ )
4074        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(3); kde=dom_end_rev(3);
4075        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(2); jme=  MemoryEnd(2); kms=MemoryStart(3); kme=  MemoryEnd(3);
4076        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(2); jpe=   PatchEnd(2); kps= PatchStart(3); kpe=   PatchEnd(3);
4077     CASE  ( DATA_ORDER_YXZ )
4078        ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(3); kde=dom_end_rev(3);
4079        ims=MemoryStart(2); ime=  MemoryEnd(2); jms=MemoryStart(1); jme=  MemoryEnd(1); kms=MemoryStart(3); kme=  MemoryEnd(3);
4080        ips= PatchStart(2); ipe=   PatchEnd(2); jps= PatchStart(1); jpe=   PatchEnd(1); kps= PatchStart(3); kpe=   PatchEnd(3);
4081     CASE  ( DATA_ORDER_ZXY )
4082        ids=DomainStart(2); ide=dom_end_rev(2); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(1); kde=dom_end_rev(1);
4083        ims=MemoryStart(2); ime=  MemoryEnd(2); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(1); kme=  MemoryEnd(1);
4084        ips= PatchStart(2); ipe=   PatchEnd(2); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(1); kpe=   PatchEnd(1);
4085     CASE  ( DATA_ORDER_ZYX )
4086        ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(2); jde=dom_end_rev(2); kds=DomainStart(1); kde=dom_end_rev(1);
4087        ims=MemoryStart(3); ime=  MemoryEnd(3); jms=MemoryStart(2); jme=  MemoryEnd(2); kms=MemoryStart(1); kme=  MemoryEnd(1);
4088        ips= PatchStart(3); ipe=   PatchEnd(3); jps= PatchStart(2); jpe=   PatchEnd(2); kps= PatchStart(1); kpe=   PatchEnd(1);
4089     CASE  ( DATA_ORDER_XZY )
4090        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
4091        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
4092        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
4093     CASE  ( DATA_ORDER_YZX )
4094        ids=DomainStart(3); ide=dom_end_rev(3); jds=DomainStart(1); jde=dom_end_rev(1); kds=DomainStart(2); kde=dom_end_rev(2);
4095        ims=MemoryStart(3); ime=  MemoryEnd(3); jms=MemoryStart(1); jme=  MemoryEnd(1); kms=MemoryStart(2); kme=  MemoryEnd(2);
4096        ips= PatchStart(3); ipe=   PatchEnd(3); jps= PatchStart(1); jpe=   PatchEnd(1); kps= PatchStart(2); kpe=   PatchEnd(2);
4097   END SELECT data_ordering
4098
4099
4100   SELECT CASE (MemOrd)
4101 #ifndef STUBMPI
4102     CASE ( 'xzy', 'yzx', 'xyz', 'yxz', 'zxy', 'zyx', 'xy', 'yx' )
4103       distributed_field = .TRUE.
4104     CASE ( 'xsz', 'xez', 'xs', 'xe' )
4105       CALL are_bdys_distributed( distributed_field )
4106     CASE ( 'ysz', 'yez', 'ys', 'ye' )
4107       CALL are_bdys_distributed( distributed_field )
4108 #endif
4109     CASE DEFAULT
4110       ! all other memory orders are replicated
4111       distributed_field = .FALSE.
4112   END SELECT
4113
4114   IF ( distributed_field ) THEN
4115
4116 ! added 8/2004 for interfaces that want the old values so they can be updated
4117     IF ( update_arg ) THEN
4118       SELECT CASE (TRIM(MemOrd))
4119         CASE (  'xzy','zxy','xyz','yxz','xy','yx' )
4120           IF ( FieldType .EQ. WRF_DOUBLE ) THEN
4121             CALL wrf_patch_to_global_double ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
4122                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4123                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4124                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
4125           ELSE IF (  FieldType .EQ. WRF_FLOAT ) THEN
4126             CALL wrf_patch_to_global_real ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
4127                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4128                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4129                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
4130           ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
4131             CALL wrf_patch_to_global_integer ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
4132                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4133                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4134                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
4135           ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
4136             CALL wrf_patch_to_global_logical ( Field  , globbuf , DomainDesc, Stagger, MemOrd ,             &
4137                DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4138                MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4139                PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3) )
4140           ENDIF
4141         CASE DEFAULT
4142       END SELECT
4143     ENDIF
4144
4145     IF ( wrf_dm_on_monitor()) THEN
4146       CALL fcn ( Hndl , DateStr , VarName , globbuf , FieldType , Comm , IOComm , &
4147                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
4148                  DomainStart , DomainEnd ,                                        &
4149                  DomainStart , dom_end_rev ,                                        &
4150                  DomainStart , DomainEnd ,                                          &
4151                  Status )
4152     ENDIF
4153
4154     CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
4155
4156     CALL lower_case( MemoryOrder, MemOrd )
4157
4158 #if defined(DM_PARALLEL) && !defined(STUBMPI)
4159 ! handle boundaries separately
4160     IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
4161          TRIM(MemOrd) .EQ. 'xs'  .OR. TRIM(MemOrd) .EQ. 'xe'  .OR. &
4162          TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
4163          TRIM(MemOrd) .EQ. 'ys'  .OR. TRIM(MemOrd) .EQ. 'ye'    ) THEN
4164
4165       IF ( TRIM(MemOrd) .EQ. 'xsz' .OR. TRIM(MemOrd) .EQ. 'xez' .OR. &
4166            TRIM(MemOrd) .EQ. 'xs'  .OR. TRIM(MemOrd) .EQ. 'xe'    ) THEN
4167
4168        jds=DomainStart(1); jde=dom_end_rev(1); ids=DomainStart(3); ide=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
4169        jms=MemoryStart(1); jme=  MemoryEnd(1); ims=MemoryStart(3); ime=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
4170        jps= PatchStart(1); jpe=   PatchEnd(1); ips= PatchStart(3); ipe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
4171
4172         IF ( nproc .GT. 1 ) THEN
4173
4174 ! Will assume that the i,j, and k dimensions correspond to the model_data_order specified by the registry --
4175 ! eg. i is (1), j is (3), and k is (2) for XZY -- and that when these are passed in for xs/xe boundary arrays (left and right
4176 ! sides of domain) the j is fully dimensioned, i is the bdy_width, and k is k. corresponding arrangement for ys/ye
4177 ! boundaries (bottom and top).  Note, however, that for the boundary arrays themselves, the innermost dimension is always
4178 ! the "full" dimension: for xs/xe, dimension 1 of the boundary arrays is j. For ys/ye, it's i. So there's a potential
4179 ! for confusion between the MODEL storage order, and which of the sd31:ed31/sd32:ed32/sd33:ed33 framework dimensions
4180 ! correspond to X/Y/Z as determined by the Registry dimespec definitions and what the storage order of the boundary
4181 ! slab arrays are (which depends on which boundaries they represent).  The k memory and domain dimensions must be set
4182 ! properly for 2d (ks=1, ke=1) versus 3d fields.
4183
4184 #if 1
4185           IF ( (MemOrd(1:2) .EQ. 'xs' .AND. bdy_mask( P_XSB )) .OR.     &
4186                (MemOrd(1:2) .EQ. 'xe' .AND. bdy_mask( P_XEB ))       ) THEN
4187             my_displ = jps-1
4188             my_count = jpe-jps+1
4189           ELSE
4190             my_displ = 0
4191             my_count = 0
4192           ENDIF
4193 #else
4194           IF ( (MemOrd(1:2) .EQ. 'xs' ) .OR.     &
4195                (MemOrd(1:2) .EQ. 'xe' )       ) THEN
4196             my_displ = jps-1
4197             my_count = jpe-jps+1
4198           ELSE
4199             my_displ = 0
4200             my_count = 0
4201           ENDIF
4202 #endif
4203
4204           CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
4205           CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
4206
4207           do i = ips,ipe    ! bdy_width
4208           do k = kds,kde    ! levels
4209              lx   = jme-jms+1
4210              lx2  = jde-jds+1
4211              idx  = lx*((k-1)+(i-1)*(kme-kms+1))
4212              idx2 = lx2*((k-1)+(i-1)*(kde-kds+1))
4213              IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
4214                CALL wrf_scatterv_double (                        &
4215                                globbuf, 1+idx2 ,                &    ! sendbuf
4216                                counts                         , &    ! sendcounts
4217                                Field, jps-jms+1+idx ,       &
4218                                my_count ,                       &    ! recvcount
4219                                displs                         , &    ! displs
4220                                collective_root                , &    ! root
4221                                communicator                   , &    ! communicator
4222                                ierr )
4223              ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
4224
4225                CALL wrf_scatterv_real (                          &
4226                                globbuf, 1+idx2 ,                &    ! sendbuf
4227                                counts                         , &    ! sendcounts
4228                                Field, jps-jms+1+idx ,       &
4229                                my_count ,                       &    ! recvcount
4230                                displs                         , &    ! displs
4231                                collective_root                , &    ! root
4232                                communicator                   , &    ! communicator
4233                                ierr )
4234
4235              ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
4236                CALL wrf_scatterv_integer (                       &
4237                                globbuf, 1+idx2 ,                &    ! sendbuf
4238                                counts                         , &    ! sendcounts
4239                                Field, jps-jms+1+idx ,       &
4240                                my_count ,                       &    ! recvcount
4241                                displs                         , &    ! displs
4242                                collective_root                , &    ! root
4243                                communicator                   , &    ! communicator
4244                                ierr )
4245              ENDIF
4246           enddo
4247           enddo
4248         ENDIF
4249       ENDIF
4250
4251       IF ( TRIM(MemOrd) .EQ. 'ysz' .OR. TRIM(MemOrd) .EQ. 'yez' .OR. &
4252            TRIM(MemOrd) .EQ. 'ys'  .OR. TRIM(MemOrd) .EQ. 'ye'    ) THEN
4253
4254
4255        ids=DomainStart(1); ide=dom_end_rev(1); jds=DomainStart(3); jde=dom_end_rev(3); kds=DomainStart(2); kde=dom_end_rev(2);
4256        ims=MemoryStart(1); ime=  MemoryEnd(1); jms=MemoryStart(3); jme=  MemoryEnd(3); kms=MemoryStart(2); kme=  MemoryEnd(2);
4257        ips= PatchStart(1); ipe=   PatchEnd(1); jps= PatchStart(3); jpe=   PatchEnd(3); kps= PatchStart(2); kpe=   PatchEnd(2);
4258
4259         IF ( nproc .GT. 1 ) THEN
4260
4261 #if 1
4262           IF ( (MemOrd(1:2) .EQ. 'ys' .AND. bdy_mask( P_YSB )) .OR.     &
4263                (MemOrd(1:2) .EQ. 'ye' .AND. bdy_mask( P_YEB ))       ) THEN
4264             my_displ = ips-1
4265             my_count = ipe-ips+1
4266            ELSE
4267              my_displ = 0
4268              my_count = 0
4269           ENDIF
4270 #else
4271           IF ( (MemOrd(1:2) .EQ. 'ys' ) .OR.     &
4272                (MemOrd(1:2) .EQ. 'ye' )       ) THEN
4273             my_displ = ips-1
4274             my_count = ipe-ips+1
4275           ELSE
4276             my_displ = 0
4277             my_count = 0
4278           ENDIF
4279 #endif
4280
4281           CALL mpi_gather( my_displ, 1, MPI_INTEGER, displs, 1, MPI_INTEGER, collective_root, communicator, ierr )
4282           CALL mpi_gather( my_count, 1, MPI_INTEGER, counts, 1, MPI_INTEGER, collective_root, communicator, ierr )
4283
4284           do j = jds,jde    ! bdy_width
4285           do k = kds,kde    ! levels
4286              lx   = ime-ims+1
4287              lx2  = ide-ids+1
4288              idx  = lx*((k-1)+(j-1)*(kme-kms+1))
4289              idx2 = lx2*((k-1)+(j-1)*(kde-kds+1))
4290
4291              IF ( FieldType .EQ. WRF_DOUBLE  ) THEN
4292                CALL wrf_scatterv_double (                        &
4293                                globbuf, 1+idx2 ,                &    ! sendbuf
4294                                counts                         , &    ! sendcounts
4295                                Field, ips-ims+1+idx ,       &
4296                                my_count ,                       &    ! recvcount
4297                                displs                         , &    ! displs
4298                                collective_root                , &    ! root
4299                                communicator                   , &    ! communicator
4300                                ierr )
4301              ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
4302                CALL wrf_scatterv_real (                          &
4303                                globbuf, 1+idx2 ,                &    ! sendbuf
4304                                counts                         , &    ! sendcounts
4305                                Field, ips-ims+1+idx ,       &
4306                                my_count ,                       &    ! recvcount
4307                                displs                         , &    ! displs
4308                                collective_root                , &    ! root
4309                                communicator                   , &    ! communicator
4310                                ierr )
4311              ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
4312                CALL wrf_scatterv_integer (                       &
4313                                globbuf, 1+idx2 ,                &    ! sendbuf
4314                                counts                         , &    ! sendcounts
4315                                Field, ips-ims+1+idx ,       &
4316                                my_count ,                       &    ! recvcount
4317                                displs                         , &    ! displs
4318                                collective_root                , &    ! root
4319                                communicator                   , &    ! communicator
4320                                ierr )
4321              ENDIF
4322           enddo
4323           enddo
4324         ENDIF
4325       ENDIF
4326
4327     ELSE  ! not a boundary
4328
4329       IF ( FieldType .EQ. WRF_DOUBLE ) THEN
4330
4331         SELECT CASE (MemOrd)
4332         CASE ( 'xzy','xyz','yxz','zxy' )
4333           CALL wrf_global_to_patch_double (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
4334              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4335              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4336              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
4337         CASE ( 'xy','yx' )
4338           CALL wrf_global_to_patch_double (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
4339              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
4340              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
4341              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
4342         END SELECT
4343
4344       ELSE IF ( FieldType .EQ. WRF_FLOAT ) THEN
4345
4346         SELECT CASE (MemOrd)
4347         CASE ( 'xzy','xyz','yxz','zxy' )
4348           CALL wrf_global_to_patch_real (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
4349              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4350              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4351              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
4352         CASE ( 'xy','yx' )
4353           CALL wrf_global_to_patch_real (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
4354              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
4355              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
4356              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
4357         END SELECT
4358
4359       ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
4360
4361         SELECT CASE (MemOrd)
4362         CASE ( 'xzy','xyz','yxz','zxy' )
4363           CALL wrf_global_to_patch_integer (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
4364              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4365              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4366              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
4367         CASE ( 'xy','yx' )
4368           CALL wrf_global_to_patch_integer (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
4369              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
4370              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
4371              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
4372         END SELECT
4373
4374       ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
4375
4376         SELECT CASE (MemOrd)
4377         CASE ( 'xzy','xyz','yxz','zxy' )
4378           CALL wrf_global_to_patch_logical (  globbuf,  Field  , DomainDesc, Stagger, MemOrd ,    &
4379              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), DomainStart(3), DomainEnd(3), &
4380              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), MemoryStart(3), MemoryEnd(3), &
4381              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , PatchStart(3) , PatchEnd(3)  )
4382         CASE ( 'xy','yx' )
4383           CALL wrf_global_to_patch_logical (  globbuf, Field ,  DomainDesc, Stagger, MemOrd ,  &
4384              DomainStart(1), DomainEnd(1), DomainStart(2), DomainEnd(2), 1            , 1 , &
4385              MemoryStart(1), MemoryEnd(1), MemoryStart(2), MemoryEnd(2), 1            , 1 , &
4386              PatchStart(1) , PatchEnd(1) , PatchStart(2) , PatchEnd(2) , 1            , 1   )
4387         END SELECT
4388
4389       ENDIF
4390     ENDIF
4391 #endif
4392
4393   ELSE ! not a distributed field
4394
4395     IF ( wrf_dm_on_monitor()) THEN
4396       CALL fcn ( Hndl , DateStr , VarName , Field   , FieldType , Comm , IOComm , &
4397                  DomainDesc , MemoryOrder , Stagger , DimNames ,                  &
4398                  DomainStart , DomainEnd ,                                        &
4399                  MemoryStart , MemoryEnd ,                                        &
4400                  PatchStart  , PatchEnd  ,                                        &
4401                  Status )
4402     ENDIF
4403     CALL wrf_dm_bcast_bytes( Status, IWORDSIZE )
4404     memsize = (MemoryEnd(1)-MemoryStart(1)+1)*(MemoryEnd(2)-MemoryStart(2)+1)*(MemoryEnd(3)-MemoryStart(3)+1)
4405     IF ( FieldType .EQ. WRF_DOUBLE ) THEN
4406       CALL wrf_dm_bcast_bytes( Field , DWORDSIZE*memsize )
4407     ELSE IF ( FieldType .EQ. WRF_FLOAT) THEN
4408       CALL wrf_dm_bcast_bytes( Field , RWORDSIZE*memsize )
4409     ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
4410       CALL wrf_dm_bcast_bytes( Field , IWORDSIZE*memsize )
4411     ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
4412       CALL wrf_dm_bcast_bytes( Field , LWORDSIZE*memsize )
4413     ENDIF
4414
4415   ENDIF
4416
4417   DEALLOCATE(displs)
4418   DEALLOCATE(counts)
4419   RETURN
4420 END SUBROUTINE call_pkg_and_dist_generic
4421
4422 !!!!!!  Miscellaneous routines
4423
4424 ! stole these routines from io_netcdf external package; changed names to avoid collisions
4425 SUBROUTINE dim_from_memorder(MemoryOrder,NDim)
4426 !<DESCRIPTION>
4427 !<PRE>
4428 ! Decodes array ranks from memory order.
4429 !</PRE>
4430 !</DESCRIPTION>
4431   CHARACTER*(*) ,INTENT(IN)  :: MemoryOrder
4432   INTEGER       ,INTENT(OUT) :: NDim
4433 !Local
4434   CHARACTER*3                :: MemOrd
4435 !
4436   CALL Lower_Case(MemoryOrder,MemOrd)
4437   SELECT CASE (MemOrd)
4438     CASE ('xyz','xzy','yxz','yzx','zxy','zyx')
4439       NDim = 3
4440     CASE ('xy','yx')
4441       NDim = 2
4442     CASE ('z','c','0')
4443       NDim = 1
4444     CASE DEFAULT
4445       NDim = 0
4446       RETURN
4447   END SELECT
4448   RETURN
4449 END SUBROUTINE dim_from_memorder
4450
4451 SUBROUTINE lower_case(MemoryOrder,MemOrd)
4452 !<DESCRIPTION>
4453 !<PRE>
4454 ! Translates upper-case characters to lower-case.
4455 !</PRE>
4456 !</DESCRIPTION>
4457   CHARACTER*(*) ,INTENT(IN)  :: MemoryOrder
4458   CHARACTER*(*) ,INTENT(OUT) :: MemOrd
4459 !Local
4460   CHARACTER*1                :: c
4461   INTEGER       ,PARAMETER   :: upper_to_lower =IACHAR('a')-IACHAR('A')
4462   INTEGER                    :: i,n,n1
4463 !
4464   MemOrd = ' '
4465   N = len(MemoryOrder)
4466   N1 = len(MemOrd)
4467   N = MIN(N,N1)
4468   MemOrd(1:N) = MemoryOrder(1:N)
4469   DO i=1,N
4470     c = MemoryOrder(i:i)
4471     if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower)
4472   ENDDO
4473   RETURN
4474 END SUBROUTINE Lower_Case
4475
4476 LOGICAL FUNCTION has_char( str, c )
4477 !<DESCRIPTION>
4478 !<PRE>
4479 ! Returns .TRUE. iff string str contains character c.  Ignores character case.
4480 !</PRE>
4481 !</DESCRIPTION>
4482   IMPLICIT NONE
4483   CHARACTER*(*) str
4484   CHARACTER c, d
4485   CHARACTER*80 str1, str2, str3
4486   INTEGER i
4487
4488   CALL lower_case( TRIM(str), str1 )
4489   str2 = ""
4490   str2(1:1) = c
4491   CALL lower_case( str2, str3 )
4492   d = str3(1:1)
4493   DO i = 1, LEN(TRIM(str1))
4494     IF ( str1(i:i) .EQ. d ) THEN
4495       has_char = .TRUE.
4496       RETURN
4497     ENDIF
4498   ENDDO
4499   has_char = .FALSE.
4500   RETURN
4501 END FUNCTION has_char
4502