geogrid/src/output_module.F

   1 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   2 ! MODULE OUTPUT_MODULE
   3 !
   4 ! This module handles the output of the fields that are generated by the main
   5 !   geogrid routines. This output may include output to a console and output to
   6 !   the WRF I/O API.
   7 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   8 module output_module
   9
  10    use parallel_module
  11    use gridinfo_module
  12    use misc_definitions_module
  13    use module_debug
  14 #ifdef IO_BINARY
  15    use module_internal_header_util
  16 #endif
  17
  18    integer, parameter :: MAX_DIMENSIONS = 3
  19
  20 #ifdef _GEOGRID
  21    ! Information about fields that will be written
  22    integer :: NUM_AUTOMATIC_FIELDS    ! Set later, but very near to a parameter
  23 #endif
  24
  25    integer :: NUM_FIELDS
  26
  27    type field_info
  28       integer :: ndims, istagger
  29       integer, dimension(MAX_DIMENSIONS) :: dom_start, mem_start, patch_start
  30       integer, dimension(MAX_DIMENSIONS) :: dom_end, mem_end, patch_end
  31       integer :: sr_x, sr_y
  32       real, pointer, dimension(:,:,:) :: rdata_arr
  33
  34       character (len=128), dimension(MAX_DIMENSIONS) :: dimnames
  35       character (len=128) :: fieldname, mem_order, stagger, units, descr
  36    end type field_info
  37
  38    type (field_info), pointer, dimension(:) :: fields
  39
  40    ! WRF I/O API related variables
  41    integer :: handle
  42
  43    contains
  44
  45
  46    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  47    ! Name: output_init
  48    !
  49    ! Purpose: To initialize the output module. Such initialization may include
  50    !   opening an X window, and making initialization calls to an I/O API.
  51    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  52    subroutine output_init(nest_number, title, datestr, grid_type, dynopt, &
  53                           corner_lats, corner_lons, &
  54                           start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
  55                           start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
  56                           start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
  57                           extra_col, extra_row)
  58
  59 #ifdef _GEOGRID
  60       use llxy_module
  61       use source_data_module
  62 #endif
  63
  64       implicit none
  65
  66       ! Arguments
  67       integer, intent(in) :: nest_number, dynopt, &
  68                              start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
  69                              start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
  70                              start_mem_1, end_mem_1, start_mem_2, end_mem_2
  71       real, dimension(16), intent(in) :: corner_lats, corner_lons
  72       logical, intent(in) :: extra_col, extra_row
  73       character (len=1), intent(in) :: grid_type
  74       character (len=19), intent(in) :: datestr
  75       character (len=*), intent(in) :: title
  76
  77 #include "wrf_io_flags.h"
  78 #include "wrf_status_codes.h"
  79
  80       ! Local variables
  81       integer :: i, istatus, save_domain, comm_1, comm_2
  82       integer :: sp1, ep1, sp2, ep2, ep1_stag, ep2_stag
  83       integer :: ngeo_flags
  84       integer :: num_land_cat, min_land_cat, max_land_cat
  85       real :: dx, dy, cen_lat, cen_lon, moad_cen_lat
  86       character (len=128) :: coption, temp_fldname
  87       character (len=128), dimension(1) :: geo_flags
  88       character (len=MAX_FILENAME_LEN) :: output_fname
  89       logical :: supports_training, supports_3d_fields
  90
  91       call init_output_fields(nest_number, grid_type, &
  92                               start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
  93                               start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
  94                               start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
  95                               extra_col, extra_row)
  96
  97       if (my_proc_id == IO_NODE .or. do_tiled_output) then
  98       istatus = 0
  99 #ifdef IO_BINARY
 100       if (io_form_output == BINARY) call ext_int_ioinit('sysdep info', istatus)
 101 #endif
 102 #ifdef IO_NETCDF
 103       if (io_form_output == NETCDF) call ext_ncd_ioinit('sysdep info', istatus)
 104 #endif
 105 #ifdef IO_GRIB1
 106       if (io_form_output == GRIB1) call ext_gr1_ioinit('sysdep info', istatus)
 107 #endif
 108       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioinit')
 109
 110       ! Find out what this implementation of WRF I/O API supports
 111       istatus = 0
 112 #ifdef IO_BINARY
 113       if (io_form_output == BINARY) coption = 'REQUIRE'
 114 #endif
 115 #ifdef IO_NETCDF
 116       if (io_form_output == NETCDF) call ext_ncd_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
 117 #endif
 118 #ifdef IO_GRIB1
 119       if (io_form_output == GRIB1) call ext_gr1_inquiry('OPEN_COMMIT_WRITE',coption,istatus)
 120 #endif
 121       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
 122
 123       if (index(coption,'ALLOW') /= 0) then
 124          supports_training = .false.
 125       else if (index(coption,'REQUIRE') /= 0) then
 126          supports_training = .true.
 127       else if (index(coption,'NO') /= 0) then
 128          supports_training = .false.
 129       end if
 130
 131       istatus = 0
 132 #ifdef IO_BINARY
 133       if (io_form_output == BINARY) coption = 'YES'
 134 #endif
 135 #ifdef IO_NETCDF
 136       if (io_form_output == NETCDF) call ext_ncd_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
 137 #endif
 138 #ifdef IO_GRIB1
 139       if (io_form_output == GRIB1) call ext_gr1_inquiry('SUPPORT_3D_FIELDS',coption,istatus)
 140 #endif
 141       call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_inquiry')
 142
 143       if (index(coption,'YES') /= 0) then
 144          supports_3d_fields = .true.
 145       else if (index(coption,'NO') /= 0) then
 146          supports_3d_fields = .false.
 147 ! BUG: What if we have no plans to write 3-d fields? We should take this into account.
 148          call mprintf(.true.,ERROR,'WRF I/O API implementation does NOT support 3-d fields.')
 149       end if
 150
 151       comm_1 = 1
 152       comm_2 = 1
 153
 154 #ifdef _GEOGRID
 155       output_fname = ' '
 156       if (grid_type == 'C') then
 157 #ifdef IO_BINARY
 158          if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .int'
 159 #endif
 160 #ifdef IO_NETCDF
 161          if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .nc'
 162 #endif
 163 #ifdef IO_GRIB1
 164          if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_em.d  .grib'
 165 #endif
 166          i = len_trim(opt_output_from_geogrid_path)
 167          write(output_fname(i+9:i+10),'(i2.2)') nest_number
 168       else if (grid_type == 'E') then
 169          if (nest_number == 1) then
 170 #ifdef IO_BINARY
 171             if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .int'
 172 #endif
 173 #ifdef IO_NETCDF
 174             if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .nc'
 175 #endif
 176 #ifdef IO_GRIB1
 177             if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm.d  .grib'
 178 #endif
 179             i = len_trim(opt_output_from_geogrid_path)
 180             write(output_fname(i+10:i+11),'(i2.2)') nest_number
 181          else
 182 #ifdef IO_BINARY
 183             if (io_form_output == BINARY) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .int'
 184 #endif
 185 #ifdef IO_NETCDF
 186             if (io_form_output == NETCDF) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .nc'
 187 #endif
 188 #ifdef IO_GRIB1
 189             if (io_form_output == GRIB1) output_fname = trim(opt_output_from_geogrid_path)//'geo_nmm_nest.l  .grib'
 190 #endif
 191             i = len_trim(opt_output_from_geogrid_path)
 192             write(output_fname(i+15:i+16),'(i2.2)') nest_number-1
 193          end if
 194       end if
 195
 196       if (nprocs > 1 .and. do_tiled_output) then
 197          write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
 198               '_', my_proc_id
 199       end if
 200 #endif
 201
 202 #ifdef _METGRID
 203       output_fname = ' '
 204       if (grid_type == 'C') then
 205 #ifdef IO_BINARY
 206          if (io_form_output == BINARY) then
 207             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.int'
 208          end if
 209 #endif
 210 #ifdef IO_NETCDF
 211          if (io_form_output == NETCDF) then
 212             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.nc'
 213          end if
 214 #endif
 215 #ifdef IO_GRIB1
 216          if (io_form_output == GRIB1) then
 217             output_fname = trim(opt_output_from_metgrid_path)//'met_em.d  .'//trim(datestr)//'.grib'
 218          end if
 219 #endif
 220          i = len_trim(opt_output_from_metgrid_path)
 221          write(output_fname(i+9:i+10),'(i2.2)') nest_number
 222       else if (grid_type == 'E') then
 223 #ifdef IO_BINARY
 224          if (io_form_output == BINARY) then
 225             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.int'
 226          end if
 227 #endif
 228 #ifdef IO_NETCDF
 229          if (io_form_output == NETCDF) then
 230             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.nc'
 231          end if
 232 #endif
 233 #ifdef IO_GRIB1
 234          if (io_form_output == GRIB1) then
 235             output_fname = trim(opt_output_from_metgrid_path)//'met_nmm.d  .'//trim(datestr)//'.grib'
 236          end if
 237 #endif
 238          i = len_trim(opt_output_from_metgrid_path)
 239          write(output_fname(i+10:i+11),'(i2.2)') nest_number
 240       end if
 241
 242       if (nprocs > 1 .and. do_tiled_output) then
 243          write(output_fname(len_trim(output_fname)+1:len_trim(output_fname)+5), '(a1,i4.4)') &
 244               '_', my_proc_id
 245       end if
 246 #endif
 247       end if
 248
 249       call parallel_bcast_logical(supports_training)
 250
 251       ! If the implementation requires or supports open_for_write begin/commit semantics
 252       if (supports_training) then
 253
 254          if (my_proc_id == IO_NODE .or. do_tiled_output) then
 255             istatus = 0
 256 #ifdef IO_BINARY
 257             if (io_form_output == BINARY) then
 258                call ext_int_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 259             end if
 260 #endif
 261 #ifdef IO_NETCDF
 262             if (io_form_output == NETCDF) then
 263                call ext_ncd_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 264             end if
 265 #endif
 266 #ifdef IO_GRIB1
 267             if (io_form_output == GRIB1) then
 268                call ext_gr1_open_for_write_begin(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 269             end if
 270 #endif
 271             call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_open_for_write_begin.')
 272          end if
 273
 274          do i=1,NUM_FIELDS
 275
 276             allocate(fields(i)%rdata_arr(fields(i)%mem_start(1):fields(i)%mem_end(1), &
 277                                          fields(i)%mem_start(2):fields(i)%mem_end(2), &
 278                                          fields(i)%mem_start(3):fields(i)%mem_end(3)))
 279
 280             call write_field(fields(i)%mem_start(1), fields(i)%mem_end(1), fields(i)%mem_start(2), &
 281                              fields(i)%mem_end(2), fields(i)%mem_start(3), fields(i)%mem_end(3), &
 282                              trim(fields(i)%fieldname), datestr, fields(i)%rdata_arr, is_training=.true.)
 283
 284             deallocate(fields(i)%rdata_arr)
 285
 286          end do
 287
 288          if (my_proc_id == IO_NODE .or. do_tiled_output) then
 289             istatus = 0
 290 #ifdef IO_BINARY
 291             if (io_form_output == BINARY) call ext_int_open_for_write_commit(handle, istatus)
 292 #endif
 293 #ifdef IO_NETCDF
 294             if (io_form_output == NETCDF) call ext_ncd_open_for_write_commit(handle, istatus)
 295 #endif
 296 #ifdef IO_GRIB1
 297             if (io_form_output == GRIB1) call ext_gr1_open_for_write_commit(handle, istatus)
 298 #endif
 299             call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_write_commit')
 300          end if
 301
 302       else ! No training required
 303
 304          if (my_proc_id == IO_NODE .or. do_tiled_output) then
 305             istatus = 0
 306 #ifdef IO_BINARY
 307             if (io_form_output == BINARY) then
 308                call ext_int_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 309             end if
 310 #endif
 311 #ifdef IO_NETCDF
 312             if (io_form_output == NETCDF) then
 313                call ext_ncd_open_for_write(trim(output_fname), comm_1, comm_2, 'sysdep info', handle, istatus)
 314             end if
 315 #endif
 316 #ifdef IO_GRIB1
 317             if (io_form_output == GRIB1) then
 318                call mprintf(.true.,ERROR,'In output_init(), GRIB1 requires begin/commit open sequence.')
 319             end if
 320 #endif
 321             call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_open_for_write_begin')
 322          end if
 323
 324       end if
 325
 326 #ifdef _GEOGRID
 327       sp1 = start_patch_1
 328       ep1 = end_patch_1
 329       sp2 = start_patch_2
 330       ep2 = end_patch_2
 331
 332       if (grid_type == 'C') then
 333          if (extra_col .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
 334             ep1_stag = ep1 + 1
 335          else
 336             ep1_stag = ep1
 337          end if
 338          if (extra_row .or. (my_proc_id == IO_NODE .and. .not. do_tiled_output)) then
 339             ep2_stag = ep2 + 1
 340          else
 341             ep2_stag = ep2
 342          end if
 343       else if (grid_type == 'E') then
 344          ep1 = ep1
 345          ep2 = ep2
 346          ep1_stag = ep1
 347          ep2_stag = ep2
 348       end if
 349
 350       if (grid_type == 'C') then
 351          dx = proj_stack(nest_number)%dx
 352          dy = proj_stack(nest_number)%dy
 353
 354          save_domain = iget_selected_domain()
 355
 356          ! Note: In the following, we use ixdim/2 rather than (ixdim+1)/2 because
 357          !       the i/j coordinates given to xytoll must be with respect to the
 358          !       mass grid, and ixdim and jydim are the full grid dimensions.
 359
 360          ! Get MOAD_CEN_LAT
 361          call select_domain(1)
 362          call xytoll(real(ixdim(1))/2.,real(jydim(1))/2., moad_cen_lat, cen_lon, M)
 363
 364          ! Get CEN_LAT and CEN_LON for this nest
 365          call select_domain(nest_number)
 366          call xytoll(real(ixdim(nest_number))/2.,real(jydim(nest_number))/2., cen_lat, cen_lon, M)
 367
 368          call select_domain(save_domain)
 369
 370          ngeo_flags = 1
 371          geo_flags(1) = 'FLAG_MF_XY'
 372       else if (grid_type == 'E') then
 373          dx = dxkm / 3**(nest_number-1)   ! For NMM, nest_number is really nesting level
 374          dy = dykm / 3**(nest_number-1)
 375          moad_cen_lat = 0.
 376          cen_lat=known_lat
 377          cen_lon=known_lon
 378
 379          ngeo_flags = 0
 380       end if
 381
 382       write(temp_fldname,'(a)') 'LANDUSEF'
 383       call get_max_categories(temp_fldname, min_land_cat, max_land_cat, istatus)
 384       num_land_cat = max_land_cat - min_land_cat + 1
 385
 386       ! We may now write global attributes to the file
 387       call write_global_attrs(title, datestr, grid_type, dynopt, ixdim(nest_number), jydim(nest_number), &
 388                               0, sp1, ep1, sp1, ep1_stag, sp2, ep2, sp2, ep2_stag,                       &
 389                               iproj_type, source_mminlu, num_land_cat, source_iswater, source_islake,    &
 390                               source_isice, source_isurban, source_isoilwater, nest_number,              &
 391                               parent_id(nest_number),                                                    &
 392                               nint(parent_ll_x(nest_number)), nint(parent_ll_y(nest_number)),            &
 393                               nint(parent_ur_x(nest_number)), nint(parent_ur_y(nest_number)),            &
 394                               dx, dy, cen_lat, moad_cen_lat,                                             &
 395                               cen_lon, stand_lon, truelat1, truelat2, pole_lat, pole_lon,                &
 396                               parent_grid_ratio(nest_number),                                            &
 397                               subgrid_ratio_x(nest_number), subgrid_ratio_y(nest_number),                &
 398                               corner_lats, corner_lons, flags=geo_flags, nflags=ngeo_flags)
 399 #endif
 400
 401    end subroutine output_init
 402
 403
 404    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 405    ! Name: init_output_fields
 406    !
 407    ! Purpose: To fill in structures describing each of the fields that will be
 408    !   written to the I/O API
 409    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 410    subroutine init_output_fields(nest_num, grid_type, &
 411                                  start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
 412                                  start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
 413                                  start_mem_1, end_mem_1, start_mem_2, end_mem_2, &
 414                                  extra_col, extra_row)
 415
 416
 417       ! Modules
 418 #ifdef _GEOGRID
 419       use source_data_module
 420 #endif
 421 #ifdef _METGRID
 422       use storage_module
 423 #endif
 424       use parallel_module
 425
 426       implicit none
 427
 428       ! Arguments
 429       integer, intent(in) :: nest_num
 430       integer, intent(in) :: start_dom_1, end_dom_1, start_dom_2, end_dom_2, &
 431                              start_patch_1, end_patch_1, start_patch_2, end_patch_2, &
 432                              start_mem_1, end_mem_1, start_mem_2, end_mem_2
 433       logical, intent(in) :: extra_col, extra_row
 434       character (len=1), intent(in) :: grid_type
 435
 436 #include "wrf_io_flags.h"
 437 #include "wrf_status_codes.h"
 438
 439       ! Local variables
 440       integer :: i, istagger, ifieldstatus, &
 441                  nfields, min_category, max_category
 442       integer :: lhalo_width, rhalo_width, bhalo_width, thalo_width
 443       integer :: ndims
 444       character (len=128) :: fieldname
 445       character (len=128) :: memorder, units, description
 446       character (len=128), dimension(3) :: dimnames
 447       integer :: sr_x, sr_y
 448
 449       !
 450       ! First find out how many fields there are
 451       !
 452       call reset_next_field()
 453
 454       ifieldstatus = 0
 455       nfields = 0
 456       do while (ifieldstatus == 0)
 457          call get_next_output_fieldname(nest_num, fieldname, ndims, &
 458                                         min_category, max_category, &
 459                                         istagger, memorder, dimnames, &
 460                                         units, description, sr_x, sr_y, ifieldstatus)
 461
 462          if (ifieldstatus == 0) nfields = nfields + 1
 463       end do
 464
 465 #ifdef _METGRID
 466       NUM_FIELDS = nfields
 467 #endif
 468
 469 #ifdef _GEOGRID
 470       if (grid_type == 'C') NUM_AUTOMATIC_FIELDS = 22
 471       if (grid_type == 'E') NUM_AUTOMATIC_FIELDS = 7
 472
 473       NUM_FIELDS = nfields+NUM_AUTOMATIC_FIELDS
 474       allocate(fields(NUM_FIELDS))
 475
 476       ! Automatic fields will always be on the non-refined grid
 477       sr_x=1
 478       sr_y=1
 479
 480       !
 481       ! There are some fields that will always be computed
 482       !   Initialize those fields first, followed by all user-specified fields
 483       !
 484       if (grid_type == 'C') then
 485          fields(1)%fieldname = 'XLAT_M'
 486          fields(1)%units = 'degrees latitude'
 487          fields(1)%descr = 'Latitude on mass grid'
 488
 489          fields(2)%fieldname = 'XLONG_M'
 490          fields(2)%units = 'degrees longitude'
 491          fields(2)%descr = 'Longitude on mass grid'
 492
 493          fields(3)%fieldname = 'XLAT_V'
 494          fields(3)%units = 'degrees latitude'
 495          fields(3)%descr = 'Latitude on V grid'
 496
 497          fields(4)%fieldname = 'XLONG_V'
 498          fields(4)%units = 'degrees longitude'
 499          fields(4)%descr = 'Longitude on V grid'
 500
 501          fields(5)%fieldname = 'XLAT_U'
 502          fields(5)%units = 'degrees latitude'
 503          fields(5)%descr = 'Latitude on U grid'
 504
 505          fields(6)%fieldname = 'XLONG_U'
 506          fields(6)%units = 'degrees longitude'
 507          fields(6)%descr = 'Longitude on U grid'
 508
 509          fields(7)%fieldname = 'CLAT'
 510          fields(7)%units = 'degrees latitude'
 511          fields(7)%descr = 'Computational latitude on mass grid'
 512
 513          fields(8)%fieldname = 'CLONG'
 514          fields(8)%units = 'degrees longitude'
 515          fields(8)%descr = 'Computational longitude on mass grid'
 516
 517          fields(9)%fieldname = 'MAPFAC_M'
 518          fields(9)%units = 'none'
 519          fields(9)%descr = 'Mapfactor on mass grid'
 520
 521          fields(10)%fieldname = 'MAPFAC_V'
 522          fields(10)%units = 'none'
 523          fields(10)%descr = 'Mapfactor on V grid'
 524
 525          fields(11)%fieldname = 'MAPFAC_U'
 526          fields(11)%units = 'none'
 527          fields(11)%descr = 'Mapfactor on U grid'
 528
 529          fields(12)%fieldname = 'MAPFAC_MX'
 530          fields(12)%units = 'none'
 531          fields(12)%descr = 'Mapfactor (x-dir) on mass grid'
 532
 533          fields(13)%fieldname = 'MAPFAC_VX'
 534          fields(13)%units = 'none'
 535          fields(13)%descr = 'Mapfactor (x-dir) on V grid'
 536
 537          fields(14)%fieldname = 'MAPFAC_UX'
 538          fields(14)%units = 'none'
 539          fields(14)%descr = 'Mapfactor (x-dir) on U grid'
 540
 541          fields(15)%fieldname = 'MAPFAC_MY'
 542          fields(15)%units = 'none'
 543          fields(15)%descr = 'Mapfactor (y-dir) on mass grid'
 544
 545          fields(16)%fieldname = 'MAPFAC_VY'
 546          fields(16)%units = 'none'
 547          fields(16)%descr = 'Mapfactor (y-dir) on V grid'
 548
 549          fields(17)%fieldname = 'MAPFAC_UY'
 550          fields(17)%units = 'none'
 551          fields(17)%descr = 'Mapfactor (y-dir) on U grid'
 552
 553          fields(18)%fieldname = 'E'
 554          fields(18)%units = '-'
 555          fields(18)%descr = 'Coriolis E parameter'
 556
 557          fields(19)%fieldname = 'F'
 558          fields(19)%units = '-'
 559          fields(19)%descr = 'Coriolis F parameter'
 560
 561          fields(20)%fieldname = 'SINALPHA'
 562          fields(20)%units = 'none'
 563          fields(20)%descr = 'Sine of rotation angle'
 564
 565          fields(21)%fieldname = 'COSALPHA'
 566          fields(21)%units = 'none'
 567          fields(21)%descr = 'Cosine of rotation angle'
 568
 569          fields(22)%fieldname = 'LANDMASK'
 570          fields(22)%units = 'none'
 571          fields(22)%descr = 'Landmask : 1=land, 0=water'
 572
 573       else if (grid_type == 'E') then
 574          fields(1)%fieldname = 'XLAT_M'
 575          fields(1)%units = 'degrees latitude'
 576          fields(1)%descr = 'Latitude on mass grid'
 577
 578          fields(2)%fieldname = 'XLONG_M'
 579          fields(2)%units = 'degrees longitude'
 580          fields(2)%descr = 'Longitude on mass grid'
 581
 582          fields(3)%fieldname = 'XLAT_V'
 583          fields(3)%units = 'degrees latitude'
 584          fields(3)%descr = 'Latitude on velocity grid'
 585
 586          fields(4)%fieldname = 'XLONG_V'
 587          fields(4)%units = 'degrees longitude'
 588          fields(4)%descr = 'Longitude on velocity grid'
 589
 590          fields(5)%fieldname = 'E'
 591          fields(5)%units = '-'
 592          fields(5)%descr = 'Coriolis E parameter'
 593
 594          fields(6)%fieldname = 'F'
 595          fields(6)%units = '-'
 596          fields(6)%descr = 'Coriolis F parameter'
 597
 598          fields(7)%fieldname = 'LANDMASK'
 599          fields(7)%units = 'none'
 600          fields(7)%descr = 'Landmask : 1=land, 0=water'
 601
 602       end if
 603
 604       !
 605       ! General defaults for "always computed" fields
 606       !
 607       do i=1,NUM_AUTOMATIC_FIELDS
 608          fields(i)%ndims = 2
 609          fields(i)%dom_start(1) = start_dom_1
 610          fields(i)%dom_start(2) = start_dom_2
 611          fields(i)%dom_start(3) = 1
 612          fields(i)%mem_start(1) = start_mem_1
 613          fields(i)%mem_start(2) = start_mem_2
 614          fields(i)%mem_start(3) = 1
 615          fields(i)%patch_start(1) = start_patch_1
 616          fields(i)%patch_start(2) = start_patch_2
 617          fields(i)%patch_start(3) = 1
 618          fields(i)%dom_end(1) = end_dom_1
 619          fields(i)%dom_end(2) = end_dom_2
 620          fields(i)%dom_end(3) = 1
 621          fields(i)%mem_end(1) = end_mem_1
 622          fields(i)%mem_end(2) = end_mem_2
 623          fields(i)%mem_end(3) = 1
 624          fields(i)%patch_end(1) = end_patch_1
 625          fields(i)%patch_end(2) = end_patch_2
 626          fields(i)%patch_end(3) = 1
 627          fields(i)%dimnames(3) = ' '
 628          fields(i)%mem_order = 'XY'
 629          fields(i)%stagger = 'M'
 630          fields(i)%sr_x = 1
 631          fields(i)%sr_y = 1
 632          if (grid_type == 'C') then
 633             fields(i)%istagger = M
 634          else if (grid_type == 'E') then
 635             fields(i)%istagger = HH
 636          end if
 637          fields(i)%dimnames(1) = 'west_east'
 638          fields(i)%dimnames(2) = 'south_north'
 639       end do
 640
 641       !
 642       ! Perform adjustments to metadata for non-mass-staggered "always computed" fields
 643       !
 644       if (grid_type == 'C') then
 645          ! Lat V
 646          if (extra_row) then
 647             fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
 648             fields(3)%mem_end(2) = fields(3)%mem_end(2) + 1
 649             fields(3)%patch_end(2) = fields(3)%patch_end(2) + 1
 650          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 651             fields(3)%dom_end(2) = fields(3)%dom_end(2) + 1
 652          end if
 653          fields(3)%dimnames(2) = 'south_north_stag'
 654          fields(3)%stagger = 'V'
 655          fields(3)%istagger = V
 656
 657          ! Lon V
 658          if (extra_row) then
 659             fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
 660             fields(4)%mem_end(2) = fields(4)%mem_end(2) + 1
 661             fields(4)%patch_end(2) = fields(4)%patch_end(2) + 1
 662          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 663             fields(4)%dom_end(2) = fields(4)%dom_end(2) + 1
 664          end if
 665          fields(4)%dimnames(2) = 'south_north_stag'
 666          fields(4)%stagger = 'V'
 667          fields(4)%istagger = V
 668
 669          ! Lat U
 670          if (extra_col) then
 671             fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
 672             fields(5)%mem_end(1) = fields(5)%mem_end(1) + 1
 673             fields(5)%patch_end(1) = fields(5)%patch_end(1) + 1
 674          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 675             fields(5)%dom_end(1) = fields(5)%dom_end(1) + 1
 676          end if
 677          fields(5)%dimnames(1) = 'west_east_stag'
 678          fields(5)%stagger = 'U'
 679          fields(5)%istagger = U
 680
 681          ! Lon U
 682          if (extra_col) then
 683             fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
 684             fields(6)%mem_end(1) = fields(6)%mem_end(1) + 1
 685             fields(6)%patch_end(1) = fields(6)%patch_end(1) + 1
 686          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 687             fields(6)%dom_end(1) = fields(6)%dom_end(1) + 1
 688          end if
 689          fields(6)%dimnames(1) = 'west_east_stag'
 690          fields(6)%stagger = 'U'
 691          fields(6)%istagger = U
 692
 693          ! Mapfac V
 694          if (extra_row) then
 695             fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
 696             fields(10)%mem_end(2) = fields(10)%mem_end(2) + 1
 697             fields(10)%patch_end(2) = fields(10)%patch_end(2) + 1
 698          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 699             fields(10)%dom_end(2) = fields(10)%dom_end(2) + 1
 700          end if
 701          fields(10)%dimnames(2) = 'south_north_stag'
 702          fields(10)%stagger = 'V'
 703          fields(10)%istagger = V
 704
 705          ! Mapfac U
 706          if (extra_col) then
 707             fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
 708             fields(11)%mem_end(1) = fields(11)%mem_end(1) + 1
 709             fields(11)%patch_end(1) = fields(11)%patch_end(1) + 1
 710          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 711             fields(11)%dom_end(1) = fields(11)%dom_end(1) + 1
 712          end if
 713          fields(11)%dimnames(1) = 'west_east_stag'
 714          fields(11)%stagger = 'U'
 715          fields(11)%istagger = U
 716
 717          ! Mapfac V-X
 718          if (extra_row) then
 719             fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
 720             fields(13)%mem_end(2) = fields(13)%mem_end(2) + 1
 721             fields(13)%patch_end(2) = fields(13)%patch_end(2) + 1
 722          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 723             fields(13)%dom_end(2) = fields(13)%dom_end(2) + 1
 724          end if
 725          fields(13)%dimnames(2) = 'south_north_stag'
 726          fields(13)%stagger = 'V'
 727          fields(13)%istagger = V
 728
 729          ! Mapfac U-X
 730          if (extra_col) then
 731             fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
 732             fields(14)%mem_end(1) = fields(14)%mem_end(1) + 1
 733             fields(14)%patch_end(1) = fields(14)%patch_end(1) + 1
 734          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 735             fields(14)%dom_end(1) = fields(14)%dom_end(1) + 1
 736          end if
 737          fields(14)%dimnames(1) = 'west_east_stag'
 738          fields(14)%stagger = 'U'
 739          fields(14)%istagger = U
 740
 741          ! Mapfac V-Y
 742          if (extra_row) then
 743             fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
 744             fields(16)%mem_end(2) = fields(16)%mem_end(2) + 1
 745             fields(16)%patch_end(2) = fields(16)%patch_end(2) + 1
 746          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 747             fields(16)%dom_end(2) = fields(16)%dom_end(2) + 1
 748          end if
 749          fields(16)%dimnames(2) = 'south_north_stag'
 750          fields(16)%stagger = 'V'
 751          fields(16)%istagger = V
 752
 753          ! Mapfac U-Y
 754          if (extra_col) then
 755             fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
 756             fields(17)%mem_end(1) = fields(17)%mem_end(1) + 1
 757             fields(17)%patch_end(1) = fields(17)%patch_end(1) + 1
 758          else if (my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 759             fields(17)%dom_end(1) = fields(17)%dom_end(1) + 1
 760          end if
 761          fields(17)%dimnames(1) = 'west_east_stag'
 762          fields(17)%stagger = 'U'
 763          fields(17)%istagger = U
 764
 765       else if (grid_type == 'E') then
 766          ! Lat V
 767          fields(3)%stagger = 'V'
 768          fields(3)%istagger = VV
 769
 770          ! Lon V
 771          fields(4)%stagger = 'V'
 772          fields(4)%istagger = VV
 773
 774       end if
 775 #endif
 776
 777       !
 778       ! Now set up the field_info structure for each user-specified field
 779       !
 780       call reset_next_field()
 781
 782       ifieldstatus = 0
 783 #ifdef _GEOGRID
 784       nfields = NUM_AUTOMATIC_FIELDS+1
 785 #endif
 786 #ifdef _METGRID
 787       allocate(fields(NUM_FIELDS))
 788       nfields = 1
 789 #endif
 790
 791       do while (ifieldstatus == 0)  !{
 792          call get_next_output_fieldname(nest_num, fieldname, ndims, &
 793                                       min_category, max_category, &
 794                                       istagger, memorder, dimnames, &
 795                                       units, description, sr_x, sr_y, ifieldstatus)
 796
 797          if (ifieldstatus == 0) then !{
 798
 799             fields(nfields)%ndims = ndims
 800             fields(nfields)%fieldname = fieldname
 801             fields(nfields)%istagger = istagger
 802             if (istagger == M) then
 803                fields(nfields)%stagger = 'M'
 804             else if (istagger == U) then
 805                fields(nfields)%stagger = 'U'
 806             else if (istagger == V) then
 807                fields(nfields)%stagger = 'V'
 808             else if (istagger == HH) then
 809                fields(nfields)%stagger = 'M'
 810             else if (istagger == VV) then
 811                fields(nfields)%stagger = 'V'
 812             end if
 813             fields(nfields)%mem_order = memorder
 814             fields(nfields)%dimnames(1) = dimnames(1)
 815             fields(nfields)%dimnames(2) = dimnames(2)
 816             fields(nfields)%dimnames(3) = dimnames(3)
 817             fields(nfields)%units = units
 818             fields(nfields)%descr = description
 819
 820             fields(nfields)%dom_start(1)   = start_dom_1
 821             fields(nfields)%dom_start(2)   = start_dom_2
 822             fields(nfields)%dom_start(3)   = min_category
 823             fields(nfields)%mem_start(1)   = start_mem_1
 824             fields(nfields)%mem_start(2)   = start_mem_2
 825             fields(nfields)%mem_start(3)   = min_category
 826             fields(nfields)%patch_start(1) = start_patch_1
 827             fields(nfields)%patch_start(2) = start_patch_2
 828             fields(nfields)%patch_start(3) = min_category
 829
 830             fields(nfields)%dom_end(1)   = end_dom_1
 831             fields(nfields)%dom_end(2)   = end_dom_2
 832             fields(nfields)%dom_end(3)   = max_category
 833             fields(nfields)%mem_end(1)   = end_mem_1
 834             fields(nfields)%mem_end(2)   = end_mem_2
 835             fields(nfields)%mem_end(3)   = max_category
 836             fields(nfields)%patch_end(1) = end_patch_1
 837             fields(nfields)%patch_end(2) = end_patch_2
 838             fields(nfields)%patch_end(3) = max_category
 839
 840             fields(nfields)%sr_x=sr_x
 841             fields(nfields)%sr_y=sr_y
 842
 843             if (extra_col .and. (istagger == U .or. sr_x > 1)) then !{
 844                fields(nfields)%dom_end(1)   = fields(nfields)%dom_end(1) + 1
 845                fields(nfields)%mem_end(1)   = fields(nfields)%mem_end(1) + 1
 846                fields(nfields)%patch_end(1) = fields(nfields)%patch_end(1) + 1
 847             else if ((istagger == U .or. sr_x > 1) .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 848                fields(nfields)%dom_end(1)=fields(nfields)%dom_end(1) + 1
 849             end if !}
 850
 851             if (extra_row .and. (istagger == V .or. sr_y > 1)) then !{
 852                fields(nfields)%dom_end(2)   = fields(nfields)%dom_end(2) + 1
 853                fields(nfields)%mem_end(2)   = fields(nfields)%mem_end(2) + 1
 854                fields(nfields)%patch_end(2) = fields(nfields)%patch_end(2) + 1
 855             else if ((istagger == V .or. sr_y > 1) .and. my_proc_id == IO_NODE .and. .not. do_tiled_output) then
 856                fields(nfields)%dom_end(2)=fields(nfields)%dom_end(2) + 1
 857             end if !}
 858
 859 #ifdef _METGRID
 860             lhalo_width = start_patch_1 - start_mem_1      ! Halo width on left of patch
 861             rhalo_width = end_mem_1     - end_patch_1      ! Halo width on right of patch
 862             bhalo_width = start_patch_2 - start_mem_2      ! Halo width on bottom of patch
 863             thalo_width = end_mem_2     - end_patch_2      ! Halo width on top of patch
 864 #else
 865             lhalo_width = 0
 866             rhalo_width = 0
 867             bhalo_width = 0
 868             thalo_width = 0
 869 #endif
 870
 871             if (sr_x > 1) then
 872                fields(nfields)%mem_start(1)   = (fields(nfields)%mem_start(1) + lhalo_width - 1)*sr_x + 1 - lhalo_width
 873                fields(nfields)%patch_start(1) = (fields(nfields)%patch_start(1)             - 1)*sr_x + 1
 874                fields(nfields)%dom_start(1)   = (fields(nfields)%dom_start(1)               - 1)*sr_x + 1
 875
 876                fields(nfields)%mem_end(1)     = (fields(nfields)%mem_end(1) - rhalo_width)*sr_x + rhalo_width
 877                fields(nfields)%patch_end(1)   = (fields(nfields)%patch_end(1)            )*sr_x
 878                fields(nfields)%dom_end(1)     = (fields(nfields)%dom_end(1)              )*sr_x
 879             endif
 880
 881             if (sr_y > 1) then
 882                fields(nfields)%mem_start(2)   = (fields(nfields)%mem_start(2) + bhalo_width - 1)*sr_y + 1 - bhalo_width
 883                fields(nfields)%patch_start(2) = (fields(nfields)%patch_start(2)             - 1)*sr_y + 1
 884                fields(nfields)%dom_start(2)   = (fields(nfields)%dom_start(2)               - 1)*sr_y + 1
 885
 886                fields(nfields)%mem_end(2)     = (fields(nfields)%mem_end(2) - thalo_width)*sr_y + thalo_width
 887                fields(nfields)%patch_end(2)   = (fields(nfields)%patch_end(2)            )*sr_y
 888                fields(nfields)%dom_end(2)     = (fields(nfields)%dom_end(2)              )*sr_y
 889            endif
 890
 891
 892             nfields = nfields + 1
 893
 894          end if  ! the next field given by get_next_fieldname() is valid }
 895
 896       end do  ! for each user-specified field }
 897
 898    end subroutine init_output_fields
 899
 900
 901    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 902    ! Name: write_field
 903    !
 904    ! Purpose: This routine writes the provided field to any output devices or APIs
 905    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 906    subroutine write_field(start_mem_i, end_mem_i, &
 907                           start_mem_j, end_mem_j, &
 908                           start_mem_k, end_mem_k, &
 909                           cname, datestr, real_array, is_training)
 910
 911       implicit none
 912
 913       ! Arguments
 914       integer, intent(in) :: start_mem_i, end_mem_i, start_mem_j, end_mem_j, start_mem_k, end_mem_k
 915       real, target, dimension(start_mem_i:end_mem_i, start_mem_j:end_mem_j, start_mem_k:end_mem_k), &
 916                               intent(in) :: real_array
 917       logical, intent(in), optional :: is_training
 918       character (len=19), intent(in) :: datestr
 919       character (len=*), intent(in) :: cname
 920
 921 #include "wrf_io_flags.h"
 922 #include "wrf_status_codes.h"
 923
 924       ! Local variables
 925       integer :: i
 926       integer :: istatus, comm_1, comm_2, domain_desc
 927       integer, dimension(3) :: sd, ed, sp, ep, sm, em
 928       real, pointer, dimension(:,:,:) :: real_dom_array
 929       logical :: allocated_real_locally
 930
 931       allocated_real_locally = .false.
 932
 933       ! If we are running distributed memory and need to gather all tiles onto a single processor for output
 934       if (nprocs > 1 .and. .not. do_tiled_output) then
 935          do i=1,NUM_FIELDS
 936             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
 937                   (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
 938                istatus = 0
 939
 940                ! For the gather routines below, the IO_NODE should give the full domain dimensions, but the
 941                !   memory and patch dimensions should indicate what the processor already has in its patch_array.
 942                ! This is because an array with dimensions of the full domain will be allocated, and the patch_array
 943                !   will be copied from local memory into the full domain array in the area specified by the patch
 944                !   dimensions.
 945                sd = fields(i)%dom_start
 946                ed = fields(i)%dom_end
 947                sp = fields(i)%patch_start
 948                ep = fields(i)%patch_end
 949                sm = fields(i)%mem_start
 950                em = fields(i)%mem_end
 951
 952                allocate(real_dom_array(sd(1):ed(1),sd(2):ed(2),sd(3):ed(3)))
 953                allocated_real_locally = .true.
 954                call gather_whole_field_r(real_array, &
 955                                          sm(1), em(1), sm(2), em(2), sm(3), em(3), &
 956                                          sp(1), ep(1), sp(2), ep(2), sp(3), ep(3), &
 957                                          real_dom_array, &
 958                                          sd(1), ed(1), sd(2), ed(2), sd(3), ed(3))
 959                exit
 960             end if
 961          end do
 962       else
 963          do i=1,NUM_FIELDS
 964             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
 965                  (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
 966                istatus = 0
 967                real_dom_array => real_array
 968                exit
 969             end if
 970          end do
 971       end if
 972
 973       ! Now a write call is only done if each processor writes its own file, or if we are the IO_NODE
 974       if (my_proc_id == IO_NODE .or. do_tiled_output) then
 975          comm_1 = 1
 976          comm_2 = 1
 977          domain_desc = 0
 978
 979          do i=1,NUM_FIELDS
 980             if ( (index(cname, trim(fields(i)%fieldname) ) /= 0) .and. &
 981                  (len_trim(cname) == len_trim(fields(i)%fieldname)) ) then
 982
 983                ! Here, the output array has dimensions of the full grid if it was gathered together
 984                !   from all processors
 985                if (my_proc_id == IO_NODE .and. nprocs > 1 .and. .not. do_tiled_output) then
 986                   sd = fields(i)%dom_start
 987                   ed = fields(i)%dom_end
 988                   sm = sd
 989                   em = ed
 990                   sp = sd
 991                   ep = ed
 992                ! If we are writing one file per processor, then each processor only writes out the
 993                !   part of the domain that it has in memory
 994                else
 995 ! BUG: Shouldn't we set sd/ed to be domain_start/domain_end?
 996 !      Maybe not, since patch is already adjusted for staggering; but maybe so, and also adjust
 997 !      for staggering if it is alright to pass true domain dimensions to write_field.
 998                   sd = fields(i)%patch_start
 999                   ed = fields(i)%patch_end
1000                   sp = fields(i)%patch_start
1001                   ep = fields(i)%patch_end
1002                   sm = fields(i)%mem_start
1003                   em = fields(i)%mem_end
1004                end if
1005
1006                istatus = 0
1007 #ifdef IO_BINARY
1008                if (io_form_output == BINARY) then
1009                   call ext_int_write_field(handle, datestr, trim(fields(i)%fieldname), &
1010                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1011                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1012                end if
1013 #endif
1014 #ifdef IO_NETCDF
1015                if (io_form_output == NETCDF) then
1016                   call ext_ncd_write_field(handle, datestr, trim(fields(i)%fieldname), &
1017                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1018                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1019                end if
1020 #endif
1021 #ifdef IO_GRIB1
1022                if (io_form_output == GRIB1) then
1023                   call ext_gr1_write_field(handle, datestr, trim(fields(i)%fieldname), &
1024                        real_dom_array, WRF_REAL, comm_1, comm_2, domain_desc, trim(fields(i)%mem_order), &
1025                        trim(fields(i)%stagger), fields(i)%dimnames, sd, ed, sm, em, sp, ep, istatus)
1026                end if
1027 #endif
1028                call mprintf((istatus /= 0),ERROR,'Error in ext_pkg_write_field')
1029
1030                if (present(is_training)) then
1031                   if (is_training) then
1032 #ifdef IO_BINARY
1033                      if (io_form_output == BINARY) then
1034                         call ext_int_put_var_ti_char(handle, 'units', &
1035                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1036                         call ext_int_put_var_ti_char(handle, 'description', &
1037                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1038                         call ext_int_put_var_ti_char(handle, 'stagger', &
1039                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1040                         call ext_int_put_var_ti_integer(handle,'sr_x', &
1041                                                  trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1042                         call ext_int_put_var_ti_integer(handle,'sr_y', &
1043                                                  trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1044                      end if
1045 #endif
1046 #ifdef IO_NETCDF
1047                      if (io_form_output == NETCDF) then
1048                         call ext_ncd_put_var_ti_char(handle, 'units', &
1049                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1050                         call ext_ncd_put_var_ti_char(handle, 'description', &
1051                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1052                         call ext_ncd_put_var_ti_char(handle, 'stagger', &
1053                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1054                         call ext_ncd_put_var_ti_integer(handle,'sr_x', &
1055                                                  trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1056                         call ext_ncd_put_var_ti_integer(handle,'sr_y', &
1057                                                  trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1058                     end if
1059 #endif
1060 #ifdef IO_GRIB1
1061                      if (io_form_output == GRIB1) then
1062                         call ext_gr1_put_var_ti_char(handle, 'units', &
1063                                                 trim(fields(i)%fieldname), trim(fields(i)%units), istatus)
1064                         call ext_gr1_put_var_ti_char(handle, 'description', &
1065                                                 trim(fields(i)%fieldname), trim(fields(i)%descr), istatus)
1066                         call ext_gr1_put_var_ti_char(handle, 'stagger', &
1067                                                 trim(fields(i)%fieldname), trim(fields(i)%stagger), istatus)
1068                         call ext_gr1_put_var_ti_integer(handle,'sr_x', &
1069                                                  trim(fields(i)%fieldname),(/fields(i)%sr_x/),1, istatus)
1070                         call ext_gr1_put_var_ti_integer(handle,'sr_y', &
1071                                                  trim(fields(i)%fieldname),(/fields(i)%sr_y/),1, istatus)
1072                     end if
1073 #endif
1074                   end if
1075                end if
1076                exit
1077             end if
1078          end do
1079
1080       end if
1081
1082       if (allocated_real_locally) deallocate(real_dom_array)
1083
1084    end subroutine write_field
1085
1086
1087    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1088    ! Name: write_global_attrs
1089    !
1090    ! Purpose:
1091    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1092    subroutine write_global_attrs(title, start_date, grid_type, dyn_opt,                             &
1093                                 west_east_dim, south_north_dim, bottom_top_dim,                     &
1094                                 we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,           &
1095                                 sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,           &
1096                                 map_proj, cmminlu, num_land_cat, is_water, is_lake, is_ice,         &
1097                                 is_urban, i_soilwater, grid_id, parent_id,                          &
1098                                 i_parent_start, j_parent_start, i_parent_end, j_parent_end,         &
1099                                 dx, dy, cen_lat, moad_cen_lat, cen_lon,                             &
1100                                 stand_lon, truelat1, truelat2, pole_lat, pole_lon,                  &
1101                                 parent_grid_ratio, sr_x, sr_y, corner_lats, corner_lons,            &
1102                                 num_metgrid_soil_levs,                                              &
1103                                 flags, nflags)
1104
1105       implicit none
1106
1107       ! Arguments
1108       integer, intent(in) :: dyn_opt, west_east_dim, south_north_dim, bottom_top_dim, &
1109                  we_patch_s, we_patch_e, we_patch_s_stag, we_patch_e_stag,            &
1110                  sn_patch_s, sn_patch_e, sn_patch_s_stag, sn_patch_e_stag,            &
1111                  map_proj, is_water, is_lake, is_ice, is_urban, i_soilwater,          &
1112                  grid_id, parent_id, i_parent_start, j_parent_start,                  &
1113                  i_parent_end, j_parent_end, parent_grid_ratio, sr_x, sr_y, num_land_cat
1114       integer, intent(in), optional :: num_metgrid_soil_levs
1115       integer, intent(in), optional :: nflags
1116       real, intent(in) :: dx, dy, cen_lat, moad_cen_lat, cen_lon, stand_lon, truelat1, truelat2, &
1117                  pole_lat, pole_lon
1118       real, dimension(16), intent(in) :: corner_lats, corner_lons
1119       character (len=*), intent(in) :: title, start_date, grid_type
1120       character (len=128), intent(in) :: cmminlu
1121       character (len=128), dimension(:), intent(in), optional :: flags
1122
1123       ! Local variables
1124       integer :: local_we_patch_s, local_we_patch_s_stag, &
1125                  local_we_patch_e, local_we_patch_e_stag, &
1126                  local_sn_patch_s, local_sn_patch_s_stag, &
1127                  local_sn_patch_e, local_sn_patch_e_stag
1128       integer :: i
1129       real, dimension(16) :: local_corner_lats, local_corner_lons
1130
1131       local_we_patch_s      = we_patch_s
1132       local_we_patch_s_stag = we_patch_s_stag
1133       local_we_patch_e      = we_patch_e
1134       local_we_patch_e_stag = we_patch_e_stag
1135       local_sn_patch_s      = sn_patch_s
1136       local_sn_patch_s_stag = sn_patch_s_stag
1137       local_sn_patch_e      = sn_patch_e
1138       local_sn_patch_e_stag = sn_patch_e_stag
1139       local_corner_lats = corner_lats
1140       local_corner_lons = corner_lons
1141
1142       if (nprocs > 1) then
1143
1144          if (.not. do_tiled_output) then
1145             call parallel_bcast_int(local_we_patch_s,      processors(0, 0))
1146             call parallel_bcast_int(local_we_patch_s_stag, processors(0, 0))
1147             call parallel_bcast_int(local_sn_patch_s,      processors(0, 0))
1148             call parallel_bcast_int(local_sn_patch_s_stag, processors(0, 0))
1149
1150             call parallel_bcast_int(local_we_patch_e,      processors(nproc_x-1, nproc_y-1))
1151             call parallel_bcast_int(local_we_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1152             call parallel_bcast_int(local_sn_patch_e,      processors(nproc_x-1, nproc_y-1))
1153             call parallel_bcast_int(local_sn_patch_e_stag, processors(nproc_x-1, nproc_y-1))
1154          end if
1155
1156          call parallel_bcast_real(local_corner_lats(1),  processors(0,         0))
1157          call parallel_bcast_real(local_corner_lats(2),  processors(0,         nproc_y-1))
1158          call parallel_bcast_real(local_corner_lats(3),  processors(nproc_x-1, nproc_y-1))
1159          call parallel_bcast_real(local_corner_lats(4),  processors(nproc_x-1, 0))
1160          call parallel_bcast_real(local_corner_lats(5),  processors(0,         0))
1161          call parallel_bcast_real(local_corner_lats(6),  processors(0,         nproc_y-1))
1162          call parallel_bcast_real(local_corner_lats(7),  processors(nproc_x-1, nproc_y-1))
1163          call parallel_bcast_real(local_corner_lats(8),  processors(nproc_x-1, 0))
1164          call parallel_bcast_real(local_corner_lats(9),  processors(0,         0))
1165          call parallel_bcast_real(local_corner_lats(10), processors(0,         nproc_y-1))
1166          call parallel_bcast_real(local_corner_lats(11), processors(nproc_x-1, nproc_y-1))
1167          call parallel_bcast_real(local_corner_lats(12), processors(nproc_x-1, 0))
1168          call parallel_bcast_real(local_corner_lats(13), processors(0,         0))
1169          call parallel_bcast_real(local_corner_lats(14), processors(0,         nproc_y-1))
1170          call parallel_bcast_real(local_corner_lats(15), processors(nproc_x-1, nproc_y-1))
1171          call parallel_bcast_real(local_corner_lats(16), processors(nproc_x-1, 0))
1172
1173          call parallel_bcast_real(local_corner_lons(1),  processors(0,         0))
1174          call parallel_bcast_real(local_corner_lons(2),  processors(0,         nproc_y-1))
1175          call parallel_bcast_real(local_corner_lons(3),  processors(nproc_x-1, nproc_y-1))
1176          call parallel_bcast_real(local_corner_lons(4),  processors(nproc_x-1, 0))
1177          call parallel_bcast_real(local_corner_lons(5),  processors(0,         0))
1178          call parallel_bcast_real(local_corner_lons(6),  processors(0,         nproc_y-1))
1179          call parallel_bcast_real(local_corner_lons(7),  processors(nproc_x-1, nproc_y-1))
1180          call parallel_bcast_real(local_corner_lons(8),  processors(nproc_x-1, 0))
1181          call parallel_bcast_real(local_corner_lons(9),  processors(0,         0))
1182          call parallel_bcast_real(local_corner_lons(10), processors(0,         nproc_y-1))
1183          call parallel_bcast_real(local_corner_lons(11), processors(nproc_x-1, nproc_y-1))
1184          call parallel_bcast_real(local_corner_lons(12), processors(nproc_x-1, 0))
1185          call parallel_bcast_real(local_corner_lons(13), processors(0,         0))
1186          call parallel_bcast_real(local_corner_lons(14), processors(0,         nproc_y-1))
1187          call parallel_bcast_real(local_corner_lons(15), processors(nproc_x-1, nproc_y-1))
1188          call parallel_bcast_real(local_corner_lons(16), processors(nproc_x-1, 0))
1189       end if
1190
1191       if (my_proc_id == IO_NODE .or. do_tiled_output) then
1192
1193          call ext_put_dom_ti_char          ('TITLE', title)
1194          call ext_put_dom_ti_char          ('SIMULATION_START_DATE', start_date)
1195          call ext_put_dom_ti_integer_scalar('WEST-EAST_GRID_DIMENSION', west_east_dim)
1196          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_GRID_DIMENSION', south_north_dim)
1197          call ext_put_dom_ti_integer_scalar('BOTTOM-TOP_GRID_DIMENSION', bottom_top_dim)
1198          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_UNSTAG', local_we_patch_s)
1199          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_UNSTAG', local_we_patch_e)
1200          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_START_STAG', local_we_patch_s_stag)
1201          call ext_put_dom_ti_integer_scalar('WEST-EAST_PATCH_END_STAG', local_we_patch_e_stag)
1202          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_UNSTAG', local_sn_patch_s)
1203          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_UNSTAG', local_sn_patch_e)
1204          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_START_STAG', local_sn_patch_s_stag)
1205          call ext_put_dom_ti_integer_scalar('SOUTH-NORTH_PATCH_END_STAG', local_sn_patch_e_stag)
1206          call ext_put_dom_ti_char          ('GRIDTYPE', grid_type)
1207          call ext_put_dom_ti_real_scalar   ('DX', dx)
1208          call ext_put_dom_ti_real_scalar   ('DY', dy)
1209          call ext_put_dom_ti_integer_scalar('DYN_OPT', dyn_opt)
1210          call ext_put_dom_ti_real_scalar   ('CEN_LAT', cen_lat)
1211          call ext_put_dom_ti_real_scalar   ('CEN_LON', cen_lon)
1212          call ext_put_dom_ti_real_scalar   ('TRUELAT1', truelat1)
1213          call ext_put_dom_ti_real_scalar   ('TRUELAT2', truelat2)
1214          call ext_put_dom_ti_real_scalar   ('MOAD_CEN_LAT', moad_cen_lat)
1215          call ext_put_dom_ti_real_scalar   ('STAND_LON', stand_lon)
1216          call ext_put_dom_ti_real_scalar   ('POLE_LAT', pole_lat)
1217          call ext_put_dom_ti_real_scalar   ('POLE_LON', pole_lon)
1218          call ext_put_dom_ti_real_vector   ('corner_lats', local_corner_lats, 16)
1219          call ext_put_dom_ti_real_vector   ('corner_lons', local_corner_lons, 16)
1220          call ext_put_dom_ti_integer_scalar('MAP_PROJ', map_proj)
1221          call ext_put_dom_ti_char          ('MMINLU', trim(cmminlu))
1222          call ext_put_dom_ti_integer_scalar('NUM_LAND_CAT', num_land_cat)
1223          call ext_put_dom_ti_integer_scalar('ISWATER', is_water)
1224          call ext_put_dom_ti_integer_scalar('ISLAKE', is_lake)
1225          call ext_put_dom_ti_integer_scalar('ISICE', is_ice)
1226          call ext_put_dom_ti_integer_scalar('ISURBAN', is_urban)
1227          call ext_put_dom_ti_integer_scalar('ISOILWATER', i_soilwater)
1228          call ext_put_dom_ti_integer_scalar('grid_id', grid_id)
1229          call ext_put_dom_ti_integer_scalar('parent_id', parent_id)
1230          call ext_put_dom_ti_integer_scalar('i_parent_start', i_parent_start)
1231          call ext_put_dom_ti_integer_scalar('j_parent_start', j_parent_start)
1232          call ext_put_dom_ti_integer_scalar('i_parent_end', i_parent_end)
1233          call ext_put_dom_ti_integer_scalar('j_parent_end', j_parent_end)
1234          call ext_put_dom_ti_integer_scalar('parent_grid_ratio', parent_grid_ratio)
1235          call ext_put_dom_ti_integer_scalar('sr_x',sr_x)
1236          call ext_put_dom_ti_integer_scalar('sr_y',sr_y)
1237 #ifdef _METGRID
1238          if (present(num_metgrid_soil_levs)) then
1239             call ext_put_dom_ti_integer_scalar('NUM_METGRID_SOIL_LEVELS', num_metgrid_soil_levs)
1240          end if
1241          call ext_put_dom_ti_integer_scalar('FLAG_METGRID', 1)
1242 #endif
1243
1244          if (present(nflags) .and. present(flags)) then
1245             do i=1,nflags
1246                if (flags(i) /= ' ') then
1247                   call ext_put_dom_ti_integer_scalar(trim(flags(i)), 1)
1248                end if
1249             end do
1250          end if
1251
1252       end if
1253
1254    end subroutine write_global_attrs
1255
1256
1257    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1258    ! Name: ext_put_dom_ti_integer
1259    !
1260    ! Purpose: Write a domain time-independent integer attribute to output.
1261    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1262    subroutine ext_put_dom_ti_integer_scalar(var_name, var_value)
1263
1264       implicit none
1265
1266       ! Arguments
1267       integer, intent(in) :: var_value
1268       character (len=*), intent(in) :: var_name
1269
1270       ! Local variables
1271       integer :: istatus
1272
1273 #ifdef IO_BINARY
1274       if (io_form_output == BINARY) then
1275          call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1276                                          var_value, &
1277                                          1, istatus)
1278       end if
1279 #endif
1280 #ifdef IO_NETCDF
1281       if (io_form_output == NETCDF) then
1282          call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1283                                          var_value, &
1284                                          1, istatus)
1285       end if
1286 #endif
1287 #ifdef IO_GRIB1
1288       if (io_form_output == GRIB1) then
1289          call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1290                                          var_value, &
1291                                          1, istatus)
1292       end if
1293 #endif
1294
1295       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1296
1297    end subroutine ext_put_dom_ti_integer_scalar
1298
1299
1300    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1301    ! Name: ext_put_dom_ti_integer
1302    !
1303    ! Purpose: Write a domain time-independent integer attribute to output.
1304    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1305    subroutine ext_put_dom_ti_integer_vector(var_name, var_value, n)
1306
1307       implicit none
1308
1309       ! Arguments
1310       integer, intent(in) :: n
1311       integer, dimension(n), intent(in) :: var_value
1312       character (len=*), intent(in) :: var_name
1313
1314       ! Local variables
1315       integer :: istatus
1316
1317 #ifdef IO_BINARY
1318       if (io_form_output == BINARY) then
1319          call ext_int_put_dom_ti_integer(handle, trim(var_name), &
1320                                          var_value, &
1321                                          n, istatus)
1322       end if
1323 #endif
1324 #ifdef IO_NETCDF
1325       if (io_form_output == NETCDF) then
1326          call ext_ncd_put_dom_ti_integer(handle, trim(var_name), &
1327                                          var_value, &
1328                                          n, istatus)
1329       end if
1330 #endif
1331 #ifdef IO_GRIB1
1332       if (io_form_output == GRIB1) then
1333          call ext_gr1_put_dom_ti_integer(handle, trim(var_name), &
1334                                          var_value, &
1335                                          n, istatus)
1336       end if
1337 #endif
1338
1339       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1340
1341    end subroutine ext_put_dom_ti_integer_vector
1342
1343
1344    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1345    ! Name: ext_put_dom_ti_real
1346    !
1347    ! Purpose: Write a domain time-independent real attribute to output.
1348    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1349    subroutine ext_put_dom_ti_real_scalar(var_name, var_value)
1350
1351       implicit none
1352
1353       ! Arguments
1354       real, intent(in) :: var_value
1355       character (len=*), intent(in) :: var_name
1356
1357       ! Local variables
1358       integer :: istatus
1359
1360 #ifdef IO_BINARY
1361       if (io_form_output == BINARY) then
1362          call ext_int_put_dom_ti_real(handle, trim(var_name), &
1363                                          var_value, &
1364                                          1, istatus)
1365       end if
1366 #endif
1367 #ifdef IO_NETCDF
1368       if (io_form_output == NETCDF) then
1369          call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1370                                          var_value, &
1371                                          1, istatus)
1372       end if
1373 #endif
1374 #ifdef IO_GRIB1
1375       if (io_form_output == GRIB1) then
1376          call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1377                                          var_value, &
1378                                          1, istatus)
1379       end if
1380 #endif
1381
1382       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1383
1384    end subroutine ext_put_dom_ti_real_scalar
1385
1386
1387    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1388    ! Name: ext_put_dom_ti_real
1389    !
1390    ! Purpose: Write a domain time-independent real attribute to output.
1391    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1392    subroutine ext_put_dom_ti_real_vector(var_name, var_value, n)
1393
1394       implicit none
1395
1396       ! Arguments
1397       integer, intent(in) :: n
1398       real, dimension(n), intent(in) :: var_value
1399       character (len=*), intent(in) :: var_name
1400
1401       ! Local variables
1402       integer :: istatus
1403
1404 #ifdef IO_BINARY
1405       if (io_form_output == BINARY) then
1406          call ext_int_put_dom_ti_real(handle, trim(var_name), &
1407                                          var_value, &
1408                                          n, istatus)
1409       end if
1410 #endif
1411 #ifdef IO_NETCDF
1412       if (io_form_output == NETCDF) then
1413          call ext_ncd_put_dom_ti_real(handle, trim(var_name), &
1414                                          var_value, &
1415                                          n, istatus)
1416       end if
1417 #endif
1418 #ifdef IO_GRIB1
1419       if (io_form_output == GRIB1) then
1420          call ext_gr1_put_dom_ti_real(handle, trim(var_name), &
1421                                          var_value, &
1422                                          n, istatus)
1423       end if
1424 #endif
1425
1426       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1427
1428    end subroutine ext_put_dom_ti_real_vector
1429
1430
1431    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1432    ! Name: ext_put_dom_ti_char
1433    !
1434    ! Purpose: Write a domain time-independent character attribute to output.
1435    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1436    subroutine ext_put_dom_ti_char(var_name, var_value)
1437
1438       implicit none
1439
1440       ! Arguments
1441       character (len=*), intent(in) :: var_name, var_value
1442
1443       ! Local variables
1444       integer :: istatus
1445
1446 #ifdef IO_BINARY
1447       if (io_form_output == BINARY) then
1448          call ext_int_put_dom_ti_char(handle, trim(var_name), &
1449                                          trim(var_value), &
1450                                          istatus)
1451       end if
1452 #endif
1453 #ifdef IO_NETCDF
1454       if (io_form_output == NETCDF) then
1455          call ext_ncd_put_dom_ti_char(handle, trim(var_name), &
1456                                          trim(var_value), &
1457                                          istatus)
1458       end if
1459 #endif
1460 #ifdef IO_GRIB1
1461       if (io_form_output == GRIB1) then
1462          call ext_gr1_put_dom_ti_char(handle, trim(var_name), &
1463                                          trim(var_value), &
1464                                          istatus)
1465       end if
1466 #endif
1467
1468       call mprintf((istatus /= 0),ERROR,'Error in writing domain time-independent attribute')
1469
1470    end subroutine ext_put_dom_ti_char
1471
1472
1473    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1474    ! Name: output_close
1475    !
1476    ! Purpose: Finalizes all output. This may include closing windows, calling I/O
1477    !    API termination routines, or closing files.
1478    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1479    subroutine output_close()
1480
1481       implicit none
1482
1483       ! Local variables
1484       integer :: istatus
1485
1486       if (my_proc_id == IO_NODE .or. do_tiled_output) then
1487
1488          istatus = 0
1489 #ifdef IO_BINARY
1490          if (io_form_output == BINARY) call ext_int_ioclose(handle, istatus)
1491 #endif
1492 #ifdef IO_NETCDF
1493          if (io_form_output == NETCDF) call ext_ncd_ioclose(handle, istatus)
1494 #endif
1495 #ifdef IO_GRIB1
1496          if (io_form_output == GRIB1) call ext_gr1_ioclose(handle, istatus)
1497 #endif
1498          call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioclose')
1499
1500          istatus = 0
1501 #ifdef IO_BINARY
1502          if (io_form_output == BINARY) call ext_int_ioexit(istatus)
1503 #endif
1504 #ifdef IO_NETCDF
1505          if (io_form_output == NETCDF) call ext_ncd_ioexit(istatus)
1506 #endif
1507 #ifdef IO_GRIB1
1508          if (io_form_output == GRIB1) call ext_gr1_ioexit(istatus)
1509 #endif
1510          call mprintf((istatus /= 0), ERROR, 'Error in ext_pkg_ioexit')
1511
1512       end if
1513
1514       if (associated(fields)) deallocate(fields)
1515
1516    end subroutine output_close
1517
1518 end module output_module