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